SCRPW26 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 18 Nov 98 3:31 PM
;;5.3;PIMS;**144,166,370,461,1015,1016**;JUN 30, 2012;Build 20
RPT I '$D(ZTQUEUED),$E(IOST)="C" D WAIT^DICD
D BLD^SCRPW21 S SDXY=^%ZOSF("XY")
F SDI="DSV","M1","MASTER","TOT","RPT","DET","RPTAP","RPTDX","RPTTAP","RPTTDX" K ^TMP("SCRPW",$J,SDI)
S T="~",(SDSTOP,SDOUT)=0,SDT=$P(SDPAR("L",1),U),SDO(1)=$P(SDPAR("O",1),U) F SDI=1:1:6 S SDF(SDI)=$P($G(SDPAR("F",SDI)),U)
S SDI=2 F S SDI=$O(SDPAR("L",SDI)) Q:'SDI S SDX=$P(SDPAR("L",SDI),U)_$P(SDPAR("L",SDI,1),U),SDPAR("LPX",SDX,SDI)=""
S SDYR=1,SDEDT=$P(SDPAR("L",2),U)+.999999 D R0 G:SDOUT RX
I SDF(2) S SDT=$P(SDPAR("L",1),U)-10000,SDEDT=SDEDT-10000,SDYR=2 D R0 G:SDOUT RX
I SDF(5)>0 D R6 G:SDOUT RX
F SDI="TOT","RPT" Q:SDOUT D R7,STOP
G:SDOUT RX D R8,STOP G:SDOUT RX G PRT^SCRPW27
;
RX G EXIT^SCRPW27
;
STOP ;Check for stop task request
S:$D(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
;
R0 F S SDT=$O(^SCE("B",SDT)) Q:'SDT!(SDT>SDEDT)!SDOUT S SDOE=0 F S SDOE=$O(^SCE("B",SDT,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE) I $P(SDOE0,U,2),$P(SDOE0,U,4),'$P(SDOE0,U,6) D R1
Q
R1 ;Evaluate perspective
S SDSTOP=SDSTOP+1 D:SDSTOP#3000=0 STOP Q:SDOUT
;CHECK FOR TEST PATIENT
I $D(^DPT("ATEST",$P(SDOE0,U,2))) Q
K SDPER Q:'$$EVAL("P",1) M SDPER=SDX
R2 ;Evaluate limitations
; SD*5.3*559 fixes bug whereby if 2 exclude lists are included for the same Limitation, 2nd exclude is essentially ignored, i.e., Limitation: OE/DV/Exclude list and Limitation: OE/ST/Exclude list.
N SDXPAR,SDXPAR1,SDNN,SDFLAG,SDSAVE
S (SDXPAR,SDXPAR1)="",SDNN=2,SDFLAG=1,SDSAVE=0
I $O(SDPAR("L",SDNN)) S SDNN=$O(SDPAR("L",SDNN)) S:SDNN SDXPAR=$G(SDPAR("L",SDNN)) I SDNN S SDN1=0,SDN1=$O(SDPAR("L",SDNN,SDN1)) S:SDN1 SDXPAR1=$G(SDPAR("L",SDNN,SDN1)) ; SD*559 added 2nd IF and what follows it
S SDFOUND=1,SDS2=2 F S SDS2=$O(SDPAR("L",SDS2)) Q:'SDS2 D
. I $D(SDXPAR) S:SDXPAR'=$G(SDPAR("L",SDS2)) SDFLAG=0
. I $D(SDXPAR1) S SDN11=0,SDN11=$O(SDPAR("L",SDS2,SDN11)) I SDN11 S:SDXPAR1'=$G(SDPAR("L",SDS2,SDN11)) SDFLAG=0 ; SD*559 added
. S:SDFLAG SDFOUND=1
. S:'$$EVAL("L",SDS2) SDFOUND=0
. I SDFOUND I SDFLAG S SDSAVE=1
. I 'SDFLAG I 'SDFOUND S SDSAVE=0
S:SDSAVE SDFOUND=SDSAVE
Q:'SDFOUND S (SDTOT,SDI)=0 F S SDI=$O(SDPER(SDI)) Q:'SDI S SDPER=SDPER(SDI) S:$G(SDPAR("P",1,6))="D" SDPER=$P(SDPER,U,2)_U_$P(SDPER,U) D R3
K SDXPAR,SDXPAR1,SDNN,SDN1,SDN11,SDFLAG
Q
;
R3 S DFN=$P(SDOE0,U,2)
S:'SDTOT ^TMP("SCRPW",$J,"TOT",SDYR,1,1,DFN,$P(SDT,"."))="",^TMP("SCRPW",$J,"TOT",SDYR,1,1,"ENC")=$G(^TMP("SCRPW",$J,"TOT",SDYR,1,1,"ENC"))+1,SDTOT=1
S ^TMP("SCRPW",$J,"M1",$P(SDPER,U,2),$P(SDPER,U))=""
S ^TMP("SCRPW",$J,"RPT",SDYR,$P(SDPER,U,2),$P(SDPER,U),DFN,$P(SDT,"."))="",^TMP("SCRPW",$J,"RPT",SDYR,$P(SDPER,U,2),$P(SDPER,U),"ENC")=$G(^TMP("SCRPW",$J,"RPT",SDYR,$P(SDPER,U,2),$P(SDPER,U),"ENC"))+1
I $L(SDF(3)),"EB"[SDF(3) S SDPNAM=$P($G(^DPT(DFN,0)),U) I $L(SDPNAM) S ^TMP("SCRPW",$J,"DET",$$DSV(SDPER),SDPNAM,DFN,$P(SDT,"."),SDT,SDOE)=$P(SDOE0,U,4)
Q:(SDF(5)<1)!(SDYR=2)
D APAC^SCRPW24(.SDX) S SDII=0 F S SDII=$O(SDX(SDII)) Q:'SDII D R4
D DXPD^SCRPW24(.SDX) S SDII=0 F S SDII=$O(SDX(SDII)) Q:'SDII D R5(1)
D DXSD^SCRPW24(.SDX) S SDII=0 F S SDII=$O(SDX(SDII)) Q:'SDII D R5(2)
Q
;
R4 S SDX=SDX(SDII) Q:$P(SDX,U)="~~~NONE~~~" S SDQT=$P(SDX,U,3) S:'SDQT SDQT=1
S ^TMP("SCRPW",$J,"RPTAP",SDYR,$P(SDPER,U,2),$P(SDPER,U),$P(SDX,U,2))=$G(^TMP("SCRPW",$J,"RPTAP",SDYR,$P(SDPER,U,2),$P(SDPER,U),$P(SDX,U,2)))+SDQT Q
;
R5(SDZ) S SDX=SDX(SDII) Q:$P(SDX,U)="~~~NONE~~~"
F SDIII=SDZ,3 S $P(^TMP("SCRPW",$J,"RPTDX",SDYR,$P(SDPER,U,2),$P(SDPER,U),$P(SDX,U,2)),U,SDIII)=$P($G(^TMP("SCRPW",$J,"RPTDX",SDYR,$P(SDPER,U,2),$P(SDPER,U),$P(SDX,U,2))),U,SDIII)+1
Q
;
DSV(SDPER) ;Encrypt detail sort values
N SDX S SDX=$G(^TMP("SCRPW",$J,"DSV",$P(SDPER,U,2),$P(SDPER,U))) Q:SDX SDX
S (SDX,^TMP("SCRPW",$J,"DSV",0))=$G(^TMP("SCRPW",$J,"DSV",0))+1
S ^TMP("SCRPW",$J,"DSV",$P(SDPER,U,2),$P(SDPER,U))=SDX Q SDX
;
R6 S SDS1="" F S SDS1=$O(^TMP("SCRPW",$J,"RPTAP",SDS1)) Q:SDS1="" S SDS2="" F S SDS2=$O(^TMP("SCRPW",$J,"RPTAP",SDS1,SDS2)) Q:SDS2="" D R6A
D STOP Q:SDOUT
S SDS1="" F S SDS1=$O(^TMP("SCRPW",$J,"RPTDX",SDS1)) Q:SDS1="" S SDS2="" F S SDS2=$O(^TMP("SCRPW",$J,"RPTDX",SDS1,SDS2)) Q:SDS2="" D R6B
D STOP Q
;
R6A S SDS3="" F S SDS3=$O(^TMP("SCRPW",$J,"RPTAP",SDS1,SDS2,SDS3)) Q:SDS3="" S SDS4="" F S SDS4=$O(^TMP("SCRPW",$J,"RPTAP",SDS1,SDS2,SDS3,SDS4)) Q:SDS4="" D R6AS
Q
R6AS S SDQT=^TMP("SCRPW",$J,"RPTAP",SDS1,SDS2,SDS3,SDS4),^TMP("SCRPW",$J,"RPTTAP",SDS1,SDS2,SDS3,SDQT,SDS4)=""
Q
;
R6B S SDS3="" F S SDS3=$O(^TMP("SCRPW",$J,"RPTDX",SDS1,SDS2,SDS3)) Q:SDS3="" S SDS4="" F S SDS4=$O(^TMP("SCRPW",$J,"RPTDX",SDS1,SDS2,SDS3,SDS4)) Q:SDS4="" D R6BS
Q
R6BS S SDQT=$P(^TMP("SCRPW",$J,"RPTDX",SDS1,SDS2,SDS3,SDS4),U,3),^TMP("SCRPW",$J,"RPTTDX",SDS1,SDS2,SDS3,SDQT,SDS4)=""
Q
;
R7 S SDYR=0 F S SDYR=$O(^TMP("SCRPW",$J,SDI,SDYR)) Q:'SDYR S SDS1="" F S SDS1=$O(^TMP("SCRPW",$J,SDI,SDYR,SDS1)) Q:SDS1="" S SDS2="" F S SDS2=$O(^TMP("SCRPW",$J,SDI,SDYR,SDS1,SDS2)) Q:SDS2="" D R7A
Q
;
R7A S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDI,SDYR,SDS1,SDS2,DFN)) Q:'DFN S ^TMP("SCRPW",$J,SDI,SDYR,SDS1,SDS2,"UNI")=$G(^TMP("SCRPW",$J,SDI,SDYR,SDS1,SDS2,"UNI"))+1 D R7B
Q
;
R7B S SDT=0 F S SDT=$O(^TMP("SCRPW",$J,SDI,SDYR,SDS1,SDS2,DFN,SDT)) Q:'SDT S ^TMP("SCRPW",$J,SDI,SDYR,SDS1,SDS2,"VIS")=$G(^TMP("SCRPW",$J,SDI,SDYR,SDS1,SDS2,"VIS"))+1
Q
;
R8 S SDORD=$E($P(SDPAR("O",1),U,2),1,3),SDS1="" F S SDS1=$O(^TMP("SCRPW",$J,"M1",SDS1)) Q:SDS1="" S SDS2="" F S SDS2=$O(^TMP("SCRPW",$J,"M1",SDS1,SDS2)) Q:SDS2="" D R8A
Q
R8A S SDORDV=$S(SDORD="ALP":SDS1,1:+$G(^TMP("SCRPW",$J,"RPT",1,SDS1,SDS2,SDORD))),^TMP("SCRPW",$J,"MASTER",SDORDV,SDS1,SDS2)="" Q
;
EVAL(SDS1,SDS2) ;Evaluate item
D GID(SDS1,SDS2) K SDX X $P(SD(1),T,7)
I SDS1="P",SDF(1)="S" D EVIL Q $D(SDX)>1
D EV0(SDS1,SDS2) D:SDS1="P" EVIL
Q $D(SDX)>1
;
EV0(SDS1,SDS2) N X,Y,SDR1,SDR2,SDZ S SDZ=SD(3)="E",SDI=0 F S SDI=$O(SDX(SDI)) Q:'SDI S X=$P(SDX(SDI),U) D EV1
Q
;
EV1 I "LN"[SD(2) K:('SDZ&'$D(SDPAR(SDS1,SDS2,5,X))) SDX(SDI) K:(SDZ&$D(SDPAR(SDS1,SDS2,5,X))) SDX Q
S Y=$S(SD(6)="D":1,+$P(SDX(SDI),U,2)=$P(SDX(SDI),U,2):1,1:0),SDR1=$O(SDPAR(SDS1,SDS2,(4+Y),"")),SDR2=$O(SDPAR(SDS1,SDS2,(4+Y),""),-1)
I Y S:(SD(6)="D"&(SDR2#1=0)) SDR2=SDR2+.9999 K:('SDZ&(X<SDR1!(X>SDR2))) SDX(SDI) K:(SDZ&(X'<SDR1&(X'>SDR2))) SDX Q
I SD(0)="DXAD" S X=$P(SDX(SDI),U,2) D DXRNGE Q ;SD*5.3*559
S X=$P(SDX(SDI),U,2) K:('SDZ&(SDR1]X!(X]SDR2))) SDX(SDI) K:(SDZ&(SDR1']X&(X']SDR2))) SDX Q
;
EVIL ;Evaluate item limitations
N SDS2 I $D(SDX)>1 S S1=SD(0),S2=$P(SD(1),T,10) F S0=S1,S2 I $L(S0) S SDS2=0 F S SDS2=$O(SDPAR("LPX",S0,SDS2)) Q:'SDS2 D GID("L",SDS2),EV0("L",SDS2)
Q
;
GID(SDS1,SDS2) ;Get item data
;Required input: SDS1,SDS2=subscript values in SDPAR array.
K SD
S SD(0)=$P(SDPAR(SDS1,SDS2),U)_$P(SDPAR(SDS1,SDS2,1),U),SD(1)=^TMP("SCRPW",$J,"ACT",SD(0))
F SDI=2,3,6 S SD(SDI)=$P($G(SDPAR(SDS1,SDS2,SDI)),U)
Q
;
DXRNGE ; added per SD*5.3*461
N SDFLG1,SDS22,SDS23
S SDFLG1=0
S SDS22=2
F S SDS22=$O(SDPAR(SDS1,SDS22)) Q:'SDS22 D
.S SDS23=1,SDS23=$O(SDPAR(SDS1,SDS22,SDS23)) Q:'SDS23 Q:$P($G(SDPAR(SDS1,SDS22,SDS23)),U,1)'="R" ;SD*5.3*559 Quit if 2nd limitation for DX List
.S SDR1=$O(SDPAR(SDS1,SDS22,(4+Y),"")),SDR2=$O(SDPAR(SDS1,SDS22,(4+Y),""),-1)
.I ('SDZ&(SDR1']X&(X']SDR2))) S SDFLG1=1
K:'SDFLG1 SDX(SDI)
K SDFLG1,SDS22,SDS23
Q
;
TEST K DIC,DIR D BLD^SCRPW21 S DIC="^SCE(",DIC(0)="AEMQZ" D ^DIC Q:$D(DTOUT)!$D(DUOUT) Q:'Y S SDOE=+Y,SDOE0=Y(0),T="~",DIR(0)="E"
S SDI="" F S SDI=$O(^TMP("SCRPW",$J,"ACT",SDI)) Q:SDI="" S SDA=^TMP("SCRPW",$J,"ACT",SDI) W !!,$P(SDA,T) D TEST1 W ! ;D ^DIR Q:'Y
D R1
Q
TEST1 X $P(SDA,T,7) S SDII="" F S SDII=$O(SDX(SDII)) Q:'SDII W !?5,SDX(SDII)
Q
;
INTRO ;Intro. text
W !!?10,"This report can be used to produce information from the ACRP",!?10,"databases in a variety of ways. Parameter selection will",!?10,"determine how to count and screen the information."
W !!?10,"The report user is prompted for report parameters in the",!?10,"following categories:",!!?10,$$XY^SCRPW20(IORVON),"FORMAT",$$XY^SCRPW20(IORVOFF)," - determines the style of report to be printed."
W !!?10,$$XY^SCRPW20(IORVON),"PERSPECTIVE",$$XY^SCRPW20(IORVOFF)," - the element that the report will be organized",!?10,"and sub-totaled by."
W !!?10,$$XY^SCRPW20(IORVON),"LIMITATIONS",$$XY^SCRPW20(IORVOFF)," - elements that can be used to narrow the scope"
W !?10,"of the report to only include (or exclude) specified data.",!!?10,$$XY^SCRPW20(IORVON),"OUTPUT ORDER, PRINT FIELDS",$$XY^SCRPW20(IORVOFF)," - determines the order of output;"
W !?10,"allows selection of print fields for detailed patient lists." Q
SCRPW26 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 18 Nov 98 3:31 PM
+1 ;;5.3;PIMS;**144,166,370,461,1015,1016**;JUN 30, 2012;Build 20
RPT IF '$DATA(ZTQUEUED)
IF $EXTRACT(IOST)="C"
DO WAIT^DICD
+1 DO BLD^SCRPW21
SET SDXY=^%ZOSF("XY")
+2 FOR SDI="DSV","M1","MASTER","TOT","RPT","DET","RPTAP","RPTDX","RPTTAP","RPTTDX"
KILL ^TMP("SCRPW",$JOB,SDI)
+3 SET T="~"
SET (SDSTOP,SDOUT)=0
SET SDT=$PIECE(SDPAR("L",1),U)
SET SDO(1)=$PIECE(SDPAR("O",1),U)
FOR SDI=1:1:6
SET SDF(SDI)=$PIECE($GET(SDPAR("F",SDI)),U)
+4 SET SDI=2
FOR
SET SDI=$ORDER(SDPAR("L",SDI))
IF 'SDI
QUIT
SET SDX=$PIECE(SDPAR("L",SDI),U)_$PIECE(SDPAR("L",SDI,1),U)
SET SDPAR("LPX",SDX,SDI)=""
+5 SET SDYR=1
SET SDEDT=$PIECE(SDPAR("L",2),U)+.999999
DO R0
IF SDOUT
GOTO RX
+6 IF SDF(2)
SET SDT=$PIECE(SDPAR("L",1),U)-10000
SET SDEDT=SDEDT-10000
SET SDYR=2
DO R0
IF SDOUT
GOTO RX
+7 IF SDF(5)>0
DO R6
IF SDOUT
GOTO RX
+8 FOR SDI="TOT","RPT"
IF SDOUT
QUIT
DO R7
DO STOP
+9 IF SDOUT
GOTO RX
DO R8
DO STOP
IF SDOUT
GOTO RX
GOTO PRT^SCRPW27
+10 ;
RX GOTO EXIT^SCRPW27
+1 ;
STOP ;Check for stop task request
+1 IF $DATA(ZTQUEUED)
SET (SDOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)
QUIT
+2 ;
R0 FOR
SET SDT=$ORDER(^SCE("B",SDT))
IF 'SDT!(SDT>SDEDT)!SDOUT
QUIT
SET SDOE=0
FOR
SET SDOE=$ORDER(^SCE("B",SDT,SDOE))
IF 'SDOE!SDOUT
QUIT
SET SDOE0=$$GETOE^SDOE(SDOE)
IF $PIECE(SDOE0,U,2)
IF $PIECE(SDOE0,U,4)
IF '$PIECE(SDOE0,U,6)
DO R1
+1 QUIT
R1 ;Evaluate perspective
+1 SET SDSTOP=SDSTOP+1
IF SDSTOP#3000=0
DO STOP
IF SDOUT
QUIT
+2 ;CHECK FOR TEST PATIENT
+3 IF $DATA(^DPT("ATEST",$PIECE(SDOE0,U,2)))
QUIT
+4 KILL SDPER
IF '$$EVAL("P",1)
QUIT
MERGE SDPER=SDX
R2 ;Evaluate limitations
+1 ; SD*5.3*559 fixes bug whereby if 2 exclude lists are included for the same Limitation, 2nd exclude is essentially ignored, i.e., Limitation: OE/DV/Exclude list and Limitation: OE/ST/Exclude list.
+2 NEW SDXPAR,SDXPAR1,SDNN,SDFLAG,SDSAVE
+3 SET (SDXPAR,SDXPAR1)=""
SET SDNN=2
SET SDFLAG=1
SET SDSAVE=0
+4 ; SD*559 added 2nd IF and what follows it
IF $ORDER(SDPAR("L",SDNN))
SET SDNN=$ORDER(SDPAR("L",SDNN))
IF SDNN
SET SDXPAR=$GET(SDPAR("L",SDNN))
IF SDNN
SET SDN1=0
SET SDN1=$ORDER(SDPAR("L",SDNN,SDN1))
IF SDN1
SET SDXPAR1=$GET(SDPAR("L",SDNN,SDN1))
+5 SET SDFOUND=1
SET SDS2=2
FOR
SET SDS2=$ORDER(SDPAR("L",SDS2))
IF 'SDS2
QUIT
Begin DoDot:1
+6 IF $DATA(SDXPAR)
IF SDXPAR'=$GET(SDPAR("L",SDS2))
SET SDFLAG=0
+7 ; SD*559 added
IF $DATA(SDXPAR1)
SET SDN11=0
SET SDN11=$ORDER(SDPAR("L",SDS2,SDN11))
IF SDN11
IF SDXPAR1'=$GET(SDPAR("L",SDS2,SDN11))
SET SDFLAG=0
+8 IF SDFLAG
SET SDFOUND=1
+9 IF '$$EVAL("L",SDS2)
SET SDFOUND=0
+10 IF SDFOUND
IF SDFLAG
SET SDSAVE=1
+11 IF 'SDFLAG
IF 'SDFOUND
SET SDSAVE=0
End DoDot:1
+12 IF SDSAVE
SET SDFOUND=SDSAVE
+13 IF 'SDFOUND
QUIT
SET (SDTOT,SDI)=0
FOR
SET SDI=$ORDER(SDPER(SDI))
IF 'SDI
QUIT
SET SDPER=SDPER(SDI)
IF $GET(SDPAR("P",1,6))="D"
SET SDPER=$PIECE(SDPER,U,2)_U_$PIECE(SDPER,U)
DO R3
+14 KILL SDXPAR,SDXPAR1,SDNN,SDN1,SDN11,SDFLAG
+15 QUIT
+16 ;
R3 SET DFN=$PIECE(SDOE0,U,2)
+1 IF 'SDTOT
SET ^TMP("SCRPW",$JOB,"TOT",SDYR,1,1,DFN,$PIECE(SDT,"."))=""
SET ^TMP("SCRPW",$JOB,"TOT",SDYR,1,1,"ENC")=$GET(^TMP("SCRPW",$JOB,"TOT",SDYR,1,1,"ENC"))+1
SET SDTOT=1
+2 SET ^TMP("SCRPW",$JOB,"M1",$PIECE(SDPER,U,2),$PIECE(SDPER,U))=""
+3 SET ^TMP("SCRPW",$JOB,"RPT",SDYR,$PIECE(SDPER,U,2),$PIECE(SDPER,U),DFN,$PIECE(SDT,"."))=""
SET ^TMP("SCRPW",$JOB,"RPT",SDYR,$PIECE(SDPER,U,2),$PIECE(SDPER,U),"ENC")=$GET(^TMP("SCRPW",$JOB,"RPT",SDYR,$PIECE(SDPER,U,2),$PIECE(SDPER,U),"ENC"))+1
+4 IF $LENGTH(SDF(3))
IF "EB"[SDF(3)
SET SDPNAM=$PIECE($GET(^DPT(DFN,0)),U)
IF $LENGTH(SDPNAM)
SET ^TMP("SCRPW",$JOB,"DET",$$DSV(SDPER),SDPNAM,DFN,$PIECE(SDT,"."),SDT,SDOE)=$PIECE(SDOE0,U,4)
+5 IF (SDF(5)<1)!(SDYR=2)
QUIT
+6 DO APAC^SCRPW24(.SDX)
SET SDII=0
FOR
SET SDII=$ORDER(SDX(SDII))
IF 'SDII
QUIT
DO R4
+7 DO DXPD^SCRPW24(.SDX)
SET SDII=0
FOR
SET SDII=$ORDER(SDX(SDII))
IF 'SDII
QUIT
DO R5(1)
+8 DO DXSD^SCRPW24(.SDX)
SET SDII=0
FOR
SET SDII=$ORDER(SDX(SDII))
IF 'SDII
QUIT
DO R5(2)
+9 QUIT
+10 ;
R4 SET SDX=SDX(SDII)
IF $PIECE(SDX,U)="~~~NONE~~~"
QUIT
SET SDQT=$PIECE(SDX,U,3)
IF 'SDQT
SET SDQT=1
+1 SET ^TMP("SCRPW",$JOB,"RPTAP",SDYR,$PIECE(SDPER,U,2),$PIECE(SDPER,U),$PIECE(SDX,U,2))=$GET(^TMP("SCRPW",$JOB,"RPTAP",SDYR,$PIECE(SDPER,U,2),$PIECE(SDPER,U),$PIECE(SDX,U,2)))+SDQT
QUIT
+2 ;
R5(SDZ) SET SDX=SDX(SDII)
IF $PIECE(SDX,U)="~~~NONE~~~"
QUIT
+1 FOR SDIII=SDZ,3
SET $PIECE(^TMP("SCRPW",$JOB,"RPTDX",SDYR,$PIECE(SDPER,U,2),$PIECE(SDPER,U),$PIECE(SDX,U,2)),U,SDIII)=$PIECE($GET(^TMP("SCRPW",$JOB,"RPTDX",SDYR,$PIECE(SDPER,U,2),$PIECE(SDPER,U),$PIECE(SDX,U,2))),U,SDIII)+1
+2 QUIT
+3 ;
DSV(SDPER) ;Encrypt detail sort values
+1 NEW SDX
SET SDX=$GET(^TMP("SCRPW",$JOB,"DSV",$PIECE(SDPER,U,2),$PIECE(SDPER,U)))
IF SDX
QUIT SDX
+2 SET (SDX,^TMP("SCRPW",$JOB,"DSV",0))=$GET(^TMP("SCRPW",$JOB,"DSV",0))+1
+3 SET ^TMP("SCRPW",$JOB,"DSV",$PIECE(SDPER,U,2),$PIECE(SDPER,U))=SDX
QUIT SDX
+4 ;
R6 SET SDS1=""
FOR
SET SDS1=$ORDER(^TMP("SCRPW",$JOB,"RPTAP",SDS1))
IF SDS1=""
QUIT
SET SDS2=""
FOR
SET SDS2=$ORDER(^TMP("SCRPW",$JOB,"RPTAP",SDS1,SDS2))
IF SDS2=""
QUIT
DO R6A
+1 DO STOP
IF SDOUT
QUIT
+2 SET SDS1=""
FOR
SET SDS1=$ORDER(^TMP("SCRPW",$JOB,"RPTDX",SDS1))
IF SDS1=""
QUIT
SET SDS2=""
FOR
SET SDS2=$ORDER(^TMP("SCRPW",$JOB,"RPTDX",SDS1,SDS2))
IF SDS2=""
QUIT
DO R6B
+3 DO STOP
QUIT
+4 ;
R6A SET SDS3=""
FOR
SET SDS3=$ORDER(^TMP("SCRPW",$JOB,"RPTAP",SDS1,SDS2,SDS3))
IF SDS3=""
QUIT
SET SDS4=""
FOR
SET SDS4=$ORDER(^TMP("SCRPW",$JOB,"RPTAP",SDS1,SDS2,SDS3,SDS4))
IF SDS4=""
QUIT
DO R6AS
+1 QUIT
R6AS SET SDQT=^TMP("SCRPW",$JOB,"RPTAP",SDS1,SDS2,SDS3,SDS4)
SET ^TMP("SCRPW",$JOB,"RPTTAP",SDS1,SDS2,SDS3,SDQT,SDS4)=""
+1 QUIT
+2 ;
R6B SET SDS3=""
FOR
SET SDS3=$ORDER(^TMP("SCRPW",$JOB,"RPTDX",SDS1,SDS2,SDS3))
IF SDS3=""
QUIT
SET SDS4=""
FOR
SET SDS4=$ORDER(^TMP("SCRPW",$JOB,"RPTDX",SDS1,SDS2,SDS3,SDS4))
IF SDS4=""
QUIT
DO R6BS
+1 QUIT
R6BS SET SDQT=$PIECE(^TMP("SCRPW",$JOB,"RPTDX",SDS1,SDS2,SDS3,SDS4),U,3)
SET ^TMP("SCRPW",$JOB,"RPTTDX",SDS1,SDS2,SDS3,SDQT,SDS4)=""
+1 QUIT
+2 ;
R7 SET SDYR=0
FOR
SET SDYR=$ORDER(^TMP("SCRPW",$JOB,SDI,SDYR))
IF 'SDYR
QUIT
SET SDS1=""
FOR
SET SDS1=$ORDER(^TMP("SCRPW",$JOB,SDI,SDYR,SDS1))
IF SDS1=""
QUIT
SET SDS2=""
FOR
SET SDS2=$ORDER(^TMP("SCRPW",$JOB,SDI,SDYR,SDS1,SDS2))
IF SDS2=""
QUIT
DO R7A
+1 QUIT
+2 ;
R7A SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,SDI,SDYR,SDS1,SDS2,DFN))
IF 'DFN
QUIT
SET ^TMP("SCRPW",$JOB,SDI,SDYR,SDS1,SDS2,"UNI")=$GET(^TMP("SCRPW",$JOB,SDI,SDYR,SDS1,SDS2,"UNI"))+1
DO R7B
+1 QUIT
+2 ;
R7B SET SDT=0
FOR
SET SDT=$ORDER(^TMP("SCRPW",$JOB,SDI,SDYR,SDS1,SDS2,DFN,SDT))
IF 'SDT
QUIT
SET ^TMP("SCRPW",$JOB,SDI,SDYR,SDS1,SDS2,"VIS")=$GET(^TMP("SCRPW",$JOB,SDI,SDYR,SDS1,SDS2,"VIS"))+1
+1 QUIT
+2 ;
R8 SET SDORD=$EXTRACT($PIECE(SDPAR("O",1),U,2),1,3)
SET SDS1=""
FOR
SET SDS1=$ORDER(^TMP("SCRPW",$JOB,"M1",SDS1))
IF SDS1=""
QUIT
SET SDS2=""
FOR
SET SDS2=$ORDER(^TMP("SCRPW",$JOB,"M1",SDS1,SDS2))
IF SDS2=""
QUIT
DO R8A
+1 QUIT
R8A SET SDORDV=$SELECT(SDORD="ALP":SDS1,1:+$GET(^TMP("SCRPW",$JOB,"RPT",1,SDS1,SDS2,SDORD)))
SET ^TMP("SCRPW",$JOB,"MASTER",SDORDV,SDS1,SDS2)=""
QUIT
+1 ;
EVAL(SDS1,SDS2) ;Evaluate item
+1 DO GID(SDS1,SDS2)
KILL SDX
XECUTE $PIECE(SD(1),T,7)
+2 IF SDS1="P"
IF SDF(1)="S"
DO EVIL
QUIT $DATA(SDX)>1
+3 DO EV0(SDS1,SDS2)
IF SDS1="P"
DO EVIL
+4 QUIT $DATA(SDX)>1
+5 ;
EV0(SDS1,SDS2) NEW X,Y,SDR1,SDR2,SDZ
SET SDZ=SD(3)="E"
SET SDI=0
FOR
SET SDI=$ORDER(SDX(SDI))
IF 'SDI
QUIT
SET X=$PIECE(SDX(SDI),U)
DO EV1
+1 QUIT
+2 ;
EV1 IF "LN"[SD(2)
IF ('SDZ&'$DATA(SDPAR(SDS1,SDS2,5,X)))
KILL SDX(SDI)
IF (SDZ&$DATA(SDPAR(SDS1,SDS2,5,X)))
KILL SDX
QUIT
+1 SET Y=$SELECT(SD(6)="D":1,+$PIECE(SDX(SDI),U,2)=$PIECE(SDX(SDI),U,2):1,1:0)
SET SDR1=$ORDER(SDPAR(SDS1,SDS2,(4+Y),""))
SET SDR2=$ORDER(SDPAR(SDS1,SDS2,(4+Y),""),-1)
+2 IF Y
IF (SD(6)="D"&(SDR2#1=0))
SET SDR2=SDR2+.9999
IF ('SDZ&(X<SDR1!(X>SDR2)))
KILL SDX(SDI)
IF (SDZ&(X'<SDR1&(X'>SDR2)))
KILL SDX
QUIT
+3 ;SD*5.3*559
IF SD(0)="DXAD"
SET X=$PIECE(SDX(SDI),U,2)
DO DXRNGE
QUIT
+4 SET X=$PIECE(SDX(SDI),U,2)
IF ('SDZ&(SDR1]X!(X]SDR2)))
KILL SDX(SDI)
IF (SDZ&(SDR1']X&(X']SDR2)))
KILL SDX
QUIT
+5 ;
EVIL ;Evaluate item limitations
+1 NEW SDS2
IF $DATA(SDX)>1
SET S1=SD(0)
SET S2=$PIECE(SD(1),T,10)
FOR S0=S1,S2
IF $LENGTH(S0)
SET SDS2=0
FOR
SET SDS2=$ORDER(SDPAR("LPX",S0,SDS2))
IF 'SDS2
QUIT
DO GID("L",SDS2)
DO EV0("L",SDS2)
+2 QUIT
+3 ;
GID(SDS1,SDS2) ;Get item data
+1 ;Required input: SDS1,SDS2=subscript values in SDPAR array.
+2 KILL SD
+3 SET SD(0)=$PIECE(SDPAR(SDS1,SDS2),U)_$PIECE(SDPAR(SDS1,SDS2,1),U)
SET SD(1)=^TMP("SCRPW",$JOB,"ACT",SD(0))
+4 FOR SDI=2,3,6
SET SD(SDI)=$PIECE($GET(SDPAR(SDS1,SDS2,SDI)),U)
+5 QUIT
+6 ;
DXRNGE ; added per SD*5.3*461
+1 NEW SDFLG1,SDS22,SDS23
+2 SET SDFLG1=0
+3 SET SDS22=2
+4 FOR
SET SDS22=$ORDER(SDPAR(SDS1,SDS22))
IF 'SDS22
QUIT
Begin DoDot:1
+5 ;SD*5.3*559 Quit if 2nd limitation for DX List
SET SDS23=1
SET SDS23=$ORDER(SDPAR(SDS1,SDS22,SDS23))
IF 'SDS23
QUIT
IF $PIECE($GET(SDPAR(SDS1,SDS22,SDS23)),U,1)'="R"
QUIT
+6 SET SDR1=$ORDER(SDPAR(SDS1,SDS22,(4+Y),""))
SET SDR2=$ORDER(SDPAR(SDS1,SDS22,(4+Y),""),-1)
+7 IF ('SDZ&(SDR1']X&(X']SDR2)))
SET SDFLG1=1
End DoDot:1
+8 IF 'SDFLG1
KILL SDX(SDI)
+9 KILL SDFLG1,SDS22,SDS23
+10 QUIT
+11 ;
TEST KILL DIC,DIR
DO BLD^SCRPW21
SET DIC="^SCE("
SET DIC(0)="AEMQZ"
DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
IF 'Y
QUIT
SET SDOE=+Y
SET SDOE0=Y(0)
SET T="~"
SET DIR(0)="E"
+1 ;D ^DIR Q:'Y
SET SDI=""
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,"ACT",SDI))
IF SDI=""
QUIT
SET SDA=^TMP("SCRPW",$JOB,"ACT",SDI)
WRITE !!,$PIECE(SDA,T)
DO TEST1
WRITE !
+2 DO R1
+3 QUIT
TEST1 XECUTE $PIECE(SDA,T,7)
SET SDII=""
FOR
SET SDII=$ORDER(SDX(SDII))
IF 'SDII
QUIT
WRITE !?5,SDX(SDII)
+1 QUIT
+2 ;
INTRO ;Intro. text
+1 WRITE !!?10,"This report can be used to produce information from the ACRP",!?10,"databases in a variety of ways. Parameter selection will",!?10,"determine how to count and screen the information."
+2 WRITE !!?10,"The report user is prompted for report parameters in the",!?10,"following categories:",!!?10,$$XY^SCRPW20(IORVON),"FORMAT",$$XY^SCRPW20(IORVOFF)," - determines the style of report to be printed."
+3 WRITE !!?10,$$XY^SCRPW20(IORVON),"PERSPECTIVE",$$XY^SCRPW20(IORVOFF)," - the element that the report will be organized",!?10,"and sub-totaled by."
+4 WRITE !!?10,$$XY^SCRPW20(IORVON),"LIMITATIONS",$$XY^SCRPW20(IORVOFF)," - elements that can be used to narrow the scope"
+5 WRITE !?10,"of the report to only include (or exclude) specified data.",!!?10,$$XY^SCRPW20(IORVON),"OUTPUT ORDER, PRINT FIELDS",$$XY^SCRPW20(IORVOFF)," - determines the order of output;"
+6 WRITE !?10,"allows selection of print fields for detailed patient lists."
QUIT
