Routine: SCRPW26

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

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

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)

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

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

R6AS S SDQT=^TMP("SCRPW",$J,"RPTAP",SDS1,SDS2,SDS3,SDS4),^TMP("SCRPW",$J,"RPTTAP",SDS1,SDS2,SDS3,SDQT,SDS4)=""

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

R6BS S SDQT=$P(^TMP("SCRPW",$J,"RPTDX",SDS1,SDS2,SDS3,SDS4),U,3),^TMP("SCRPW",$J,"RPTTDX",SDS1,SDS2,SDS3,SDQT,SDS4)=""

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

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

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

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

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

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)

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)

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

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

TEST1 X $P(SDA,T,7) S SDII="" F  S SDII=$O(SDX(SDII)) Q:'SDII  W !?5,SDX(SDII)

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

SCRPW26.m