SCRPW50 ;RENO/KEITH - ACRP Data Validation Reports ; 15 Jul 98 4:31 PM
;;5.3;Scheduling;**144,466**;AUG 13, 1993;Build 2
RQUE(SDROU,SDES,SD132) ;Queue data validation reports
;Required input: SDROU=routine entry point to que
;Required input: SDES=report name
;Optional input: SD132='1' to flag for 132 column output
N SD,SDDIV,ZTSAVE D TITL(SDES)
G:'$$DIVA^SCRPW17(.SDDIV) EXIT S SDMD=$O(SDDIV("")),SDMD=$O(SDDIV(SDMD)) S:$P(SDDIV,U,2)="ALL DIVISIONS" SDMD=1
DATE N %DT S %DT="AEPX",%DT(0)="-NOW",%DT("A")="Produce report for Fiscal Year workload through (date): " W ! D ^%DT G:Y<1 EXIT
I Y<2961001 W !!,$C(7),"This date cannot be prior to OCT 1, 1996!" K Y G DATE
S SD("MOD")=$E(Y,1,5)_"00",SD("EDT")=Y_.99,SD("FYD")=$E(Y,1,3)_1001 S:SD("FYD")>SD("EDT") SD("FYD")=SD("FYD")-10000 X ^DD("DD") S SD("PEDT")=Y
F X="SD(","SDDIV","SDDIV(","SDMD" S ZTSAVE(X)=""
I $D(SDSTA) S ZTSAVE("SDSTA")="" ;encounter status
I $G(SD132) W !!,"This report requires 132 column output."
W ! D EN^XUTMDEVQ(SDROU,SDES,.ZTSAVE)
EXIT D END K SDMD,SD132,SDROU,SDES,SD,SDDIV,X,Y,%DT,SDX Q
;
XY(X,SDI,SDZ) ;Maintain $X, $Y
;Required input: X=screen handling variable
;Optional input: SDI=1 if indirection is needed
;Optional input: SDZ=0 if $X & $Y are to be zeroed
N DX,DY S DX=$X,DY=$Y S:$G(SDZ)=0 (DX,DY)=0
I $G(SDI),$L(X) W @X X ^%ZOSF("XY") Q ""
W X X ^%ZOSF("XY") Q ""
;
TITL(SDES) ;Display report title
;Required input: SDES=report descriptive title
N X,SDX
D ENS^%ZISS S X=0 X ^%ZOSF("RM")
I $E(IOST)'="C" W $$XY(IOF,1,0),?(IOM-$L(SDES)\2),SDES,! Q
S:$L(SDES)#1 SDES=SDES_" " S IOTM=3,IOBM=IOSL,SDX="",$P(SDX," ",(80-$L(SDES)\2+1))="",SDX=SDX_SDES_SDX W $$XY(IOF,1,0),$$XY(IORVON),SDX,$$XY(IORVOFF),$$XY(IOSTBM,1),!
Q
;
SUBT(SDX) ;Display subtitle
;Required input: SDX=subtitle text
W !!?(80-$L(SDX)\2),$$XY(IORVON),SDX,$$XY(IORVOFF) Q
;
END ;Clean up
N X S X=IOM X ^%ZOSF("RM") D DISP0^SCRPW23,KILL^%ZISS K ^TMP("SCRPW",$J) Q
;
PROV(SDOE,SDARY) ;Create array of provider types for an encounter
;Required input: SDOE=outpatient encounter ifn
;Required input: SDARY=array to return list (pass by reference)
;Output: SDARY(providerifn)=VA code of person class
K SDARY N SDAR1,SDPR,SDPRA,SDI D GETPRV^SDOE(SDOE,"SDPR")
S SDI=0 F S SDI=$O(SDPR(SDI)) Q:'SDI S SDPR=$P(SDPR(SDI),U) I SDPR D
.K SDAR1 D ROLE^VAFHLRO3(SDPR,"SDAR1","")
.I $L($G(SDAR1(1))) S SDARY(SDPR)=SDAR1(1)
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW50 2458 printed Sep 23, 2025@20:20:11 Page 2
SCRPW50 ;RENO/KEITH - ACRP Data Validation Reports ; 15 Jul 98 4:31 PM
+1 ;;5.3;Scheduling;**144,466**;AUG 13, 1993;Build 2
RQUE(SDROU,SDES,SD132) ;Queue data validation reports
+1 ;Required input: SDROU=routine entry point to que
+2 ;Required input: SDES=report name
+3 ;Optional input: SD132='1' to flag for 132 column output
+4 NEW SD,SDDIV,ZTSAVE
DO TITL(SDES)
+5 if '$$DIVA^SCRPW17(.SDDIV)
GOTO EXIT
SET SDMD=$ORDER(SDDIV(""))
SET SDMD=$ORDER(SDDIV(SDMD))
if $PIECE(SDDIV,U,2)="ALL DIVISIONS"
SET SDMD=1
DATE NEW %DT
SET %DT="AEPX"
SET %DT(0)="-NOW"
SET %DT("A")="Produce report for Fiscal Year workload through (date): "
WRITE !
DO ^%DT
if Y<1
GOTO EXIT
+1 IF Y<2961001
WRITE !!,$CHAR(7),"This date cannot be prior to OCT 1, 1996!"
KILL Y
GOTO DATE
+2 SET SD("MOD")=$EXTRACT(Y,1,5)_"00"
SET SD("EDT")=Y_.99
SET SD("FYD")=$EXTRACT(Y,1,3)_1001
if SD("FYD")>SD("EDT")
SET SD("FYD")=SD("FYD")-10000
XECUTE ^DD("DD")
SET SD("PEDT")=Y
+3 FOR X="SD(","SDDIV","SDDIV(","SDMD"
SET ZTSAVE(X)=""
+4 ;encounter status
IF $DATA(SDSTA)
SET ZTSAVE("SDSTA")=""
+5 IF $GET(SD132)
WRITE !!,"This report requires 132 column output."
+6 WRITE !
DO EN^XUTMDEVQ(SDROU,SDES,.ZTSAVE)
EXIT DO END
KILL SDMD,SD132,SDROU,SDES,SD,SDDIV,X,Y,%DT,SDX
QUIT
+1 ;
XY(X,SDI,SDZ) ;Maintain $X, $Y
+1 ;Required input: X=screen handling variable
+2 ;Optional input: SDI=1 if indirection is needed
+3 ;Optional input: SDZ=0 if $X & $Y are to be zeroed
+4 NEW DX,DY
SET DX=$X
SET DY=$Y
if $GET(SDZ)=0
SET (DX,DY)=0
+5 IF $GET(SDI)
IF $LENGTH(X)
WRITE @X
XECUTE ^%ZOSF("XY")
QUIT ""
+6 WRITE X
XECUTE ^%ZOSF("XY")
QUIT ""
+7 ;
TITL(SDES) ;Display report title
+1 ;Required input: SDES=report descriptive title
+2 NEW X,SDX
+3 DO ENS^%ZISS
SET X=0
XECUTE ^%ZOSF("RM")
+4 IF $EXTRACT(IOST)'="C"
WRITE $$XY(IOF,1,0),?(IOM-$LENGTH(SDES)\2),SDES,!
QUIT
+5 if $LENGTH(SDES)#1
SET SDES=SDES_" "
SET IOTM=3
SET IOBM=IOSL
SET SDX=""
SET $PIECE(SDX," ",(80-$LENGTH(SDES)\2+1))=""
SET SDX=SDX_SDES_SDX
WRITE $$XY(IOF,1,0),$$XY(IORVON),SDX,$$XY(IORVOFF),$$XY(IOSTBM,1),!
+6 QUIT
+7 ;
SUBT(SDX) ;Display subtitle
+1 ;Required input: SDX=subtitle text
+2 WRITE !!?(80-$LENGTH(SDX)\2),$$XY(IORVON),SDX,$$XY(IORVOFF)
QUIT
+3 ;
END ;Clean up
+1 NEW X
SET X=IOM
XECUTE ^%ZOSF("RM")
DO DISP0^SCRPW23
DO KILL^%ZISS
KILL ^TMP("SCRPW",$JOB)
QUIT
+2 ;
PROV(SDOE,SDARY) ;Create array of provider types for an encounter
+1 ;Required input: SDOE=outpatient encounter ifn
+2 ;Required input: SDARY=array to return list (pass by reference)
+3 ;Output: SDARY(providerifn)=VA code of person class
+4 KILL SDARY
NEW SDAR1,SDPR,SDPRA,SDI
DO GETPRV^SDOE(SDOE,"SDPR")
+5 SET SDI=0
FOR
SET SDI=$ORDER(SDPR(SDI))
if 'SDI
QUIT
SET SDPR=$PIECE(SDPR(SDI),U)
IF SDPR
Begin DoDot:1
+6 KILL SDAR1
DO ROLE^VAFHLRO3(SDPR,"SDAR1","")
+7 IF $LENGTH($GET(SDAR1(1)))
SET SDARY(SDPR)=SDAR1(1)
+8 QUIT
End DoDot:1
+9 QUIT
