SCRPW41.m

SCRPW41 ;RENO/KEITH - Veterans Without Activity Since a Specified Date Range ; 5/25/2004

 ;;5.3;Scheduling;**144,375,358**;AUG 13, 1993

 N DIR,%DT K SD

 D TITL^SCRPW50("Veterans Without Activity Since a Specified Date Range")

 W !!,"This report will return a list of veterans that are not deceased who had",!,"activity during a date range specified by the user, and have not been seen"

 W !,"since.  Activity is determined by an examination of Fee Basis, inpatient and",!,"outpatient care (including future appointments).  Once the scheduling"

 W !,"replacement application has been implemented at your site, this report will",!,"no longer be accurate."

 D SUBT^SCRPW50("**** Date Range Selection ****")

 W ! S %DT="AEPX",%DT("A")="Beginning date: " D ^%DT G:Y<1 EXIT^SCRPW42 S SD("BDT")=Y X ^DD("DD") S SD("PBDT")=Y

EDT S %DT("A")="   Ending date: " W ! D ^%DT G:Y<1 EXIT^SCRPW42

 I Y<SD("BDT") W !!,$C(7),"End date cannot be before begin date!",! G EDT

 S SD("EDT")=Y_.999999 X ^DD("DD") S SD("PEDT")=Y,(SDOUT,SDNUL)=0

 D BLD^SCRPW21 S SDX="" D SUBT^SCRPW50("**** Output Sort Selection (optional) ****") S DIR("?")="Sort elements selected will determine the order of output.",(SD("PAGE"),SD("SORT"))=0

 F SDI=1:1:6 S T="~",DIR("A")=$S(SDX="":"Specify data element to sort by",1:"Within "_SDX_", sort by") D ASK Q:SDOUT!SDNUL

 G:SDOUT EXIT^SCRPW42 D SUBT^SCRPW50("**** Parameters Selected ****") W !!,"Veterans not seen since the date range: ",SD("PBDT")," to ",SD("PEDT"),!!,"Output sort elements: " D

 .I SD("SORT")=0 W "(NONE SELECTED)" Q

 .S SDI=0 F  S SDI=$O(SD("SORT",SDI)) Q:'SDI  S SDX=SD("SORT",SDI) W:SDI>1 ! W ?(19+(3*SDI)) S SDL=$S($P(SDX,U,3):(69-$X),1:(80-$X)) W $E($P(SDX,U,2),1,SDL)_$S($P(SDX,U,3):" <pagefeed>",1:"")

 .Q

 K DIR S DIR(0)="Y",DIR("A")="Ok",DIR("B")="YES",DIR("?")="Specify if the parameters are satisfactory as displayed." W ! D ^DIR G:$D(DTOUT)!$D(DUOUT) EXIT^SCRPW42 G:'Y EXIT^SCRPW42

 N ZTSAVE S ZTSAVE("SD(")="" W !!,"This report requires 132 column output.",!

 D EN^XUTMDEVQ("START^SCRPW41","Veterans Without Activity Since a Specified Date",.ZTSAVE) G EXIT^SCRPW42

 ;

ASK ;Ask for sort elements

 N SDZ I $L(SDX) D SUBT^SCRPW50("**** Select "_$S(SDI=2:"second",SDI=3:"third",SDI=4:"fourth",SDI=5:"fifth",SDI=6:"sixth",1:"another")_" sort element (optional) ****")

 K DIR(0) S S1=$$DIR^SCRPW23(.DIR,1,"","","O",2) Q:SDOUT!SDNUL

 K DIR(0) S DIR("A")="Select "_$P(S1,U,2)_" data element",S2=$$DIR^SCRPW23(.DIR,2,"",$P(S1,U),"O",2,1) Q:SDOUT  I SDNUL S SDNUL=0 G ASK

 S SDX=$P(S2,U,2),SD("SORT",SDI)=$P(S1,U)_$P(S2,U)_U_SDX_U_$$PF(),SD("SORT")=SD("SORT")+1 Q

 ;

PF() ;Prompt for page feed

 N DIR S DIR(0)="Y",DIR("A")="Perform a pagefeed for each new "_SDX_" value",DIR("B")="NO",DIR("?")="Specify if you want a pagefeed between each sort value for this element." W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q 0

 S:Y SD("PAGE")=SDI Q Y

 ;

START ;Print report

 K ^TMP("SCRPW",$J) D BLD^SCRPW21 S (SDOUT,SDSTOP,DFN)=0 D NOW^%DTC S SDNOW=%,T="~"

 S SDFEE=""

 F  S DFN=$O(^DPT(DFN)) Q:'DFN  S SDSTOP=SDSTOP+1 D:SDSTOP#3000=0 STOP Q:SDOUT  I $$VET() S SDX=$$EVAL(SD("BDT"),SD("EDT")) D:$P(SDX,U)=2 SET

 G:SDOUT EXIT^SCRPW42 D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDLINE="",$P(SDLINE,"-",133)="",SDPAGE=1,(SDTOT,SDPG)=0 G ^SCRPW42

 ;

VET() ;Vet?  Alive?  Eligible?

 D DEM^VADPT Q:VADM(6) 0  ;deceased

 D ELIG^VADPT Q:'VAEL(4) 0  ;veteran

 Q VAEL(5)  ;eligible

 ;

EVAL(SDBD,SDED) ;Evaluate last activity

 ;Required input: SDBD=begin date of date range

 ;Required input: SDED=end date of date range

 ;Output: code^last activity date^location, where 'code'=

 ;        1=activity since date range

 ;        2=activity during date range, none since

 ;        3=no activity during or after date range

 N SDDT,SDX,SDXX,SDY

 S SDX=$O(^SCE("ADFN",DFN,9999999),-1) I SDX S SDY=$O(^SCE("ADFN",DFN,SDX,0)),SDY=$$GETOE^SDOE(SDY),SDY=$P($G(^SC(+$P(SDY,U,4),0)),U),SDDT(SDX)=SDY

 S SDX=$O(^DPT(DFN,"S",9999999),-1) I SDX S SDY=+$G(^DPT(DFN,"S",SDX,0)),SDY=$P($G(^SC(+SDY,0)),U),SDDT(SDX)=SDY

 S SDX=$O(^DPT(DFN,"DIS",0)) I SDX S SDDT(9999999-SDX)="REGISTRATION"

 S SDX=$O(^SDV("ADT",DFN,9999999),-1) I SDX S SDDT(SDX)="ADD/EDIT"

 ;S SDX=$O(^FBAAA(DFN,1,9999999),-1) I SDX S SDX=$P($G(^FBAAA(DFN,1,SDX,0)),U) I SDX S SDDT(SDX)="FEE BASIS"

 S SDXX=$$AUTHL^FBUTL(DFN,,SDBD,"SDX") D

 .I +SDXX=-1,$P(SDXX,"^",2)=110 S SDFEE="FEE BASIS SYSTEM NOT AVAILABLE"

 .I SDXX>0 S SDDT($G(SDX(SDXX,"FDT")))="FEE BASIS"

 S SDX=$O(^DGPM("APRD",DFN,9999999),-1) I SDX S SDY=$O(^DGPM("APRD",DFN,SDX,0)),SDY=$G(^DGPM(+SDY,0)) I $L(SDY) D

 .I $P(SDY,U,2)=1 S SDDT(SDX)=$P($G(^DIC(42,+$P(SDY,U,6),0)),U) Q

 .I $P(SDY,U,2)=3 N D0,X S D0=$O(^DGPM("APRD",DFN,SDX,0)) D WARD^DGPMUTL S SDDT(SDX)=X Q

 .D WARD(SDX) Q

 D WARD(SDNOW)

 S SDX=$O(SDDT(9999999),-1),SDX=$S('$L(SDX):U_U,1:U_SDX_U_SDDT(SDX))

 Q:$P(SDX,U,2)'<SDED 1_SDX  Q:$P(SDX,U,2)'<SDBD 2_SDX  Q 3_SDX

 ;

WARD(SDT) ;Get ward for date/time

 ;Required input: SDT=date/time

 N DGT,DG1,DGA1,DGXFR0 S DGT=SDT D ^DGPMSTAT I DG1 S SDDT(SDT)=$P($G(^DIC(42,DG1,0)),U)

 Q

 ;

SET ;Set TMP global

 S SD0=$G(^DPT(DFN,0)),SDSSN=$P(SD0,U,9),SDPNAM=$P(SD0,U) Q:'$L(SDPNAM)  S $P(SDX,U)=SDSSN

 N SDS I SD("SORT") S SDI="" F  S SDI=$O(SD("SORT",SDI)) Q:'SDI  S SDS(SDI)=$$SORT($P(SD("SORT",SDI),U))

 I 'SD("SORT") S ^TMP("SCRPW",$J,1,SDPNAM,DFN)=SDX Q

 I SD("SORT")=1 S ^TMP("SCRPW",$J,1,SDS(1),SDPNAM,DFN)=SDX Q

 I SD("SORT")=2 S ^TMP("SCRPW",$J,1,SDS(1),SDS(2),SDPNAM,DFN)=SDX Q

 I SD("SORT")=3 S ^TMP("SCRPW",$J,1,SDS(1),SDS(2),SDS(3),SDPNAM,DFN)=SDX Q

 S SDUI=$$DSV^SCRPW42(SDS(1),SDS(2),SDS(3),SDS(4))

 I SD("SORT")=4 S ^TMP("SCRPW",$J,1,SDS(1),SDS(2),SDS(3),SDS(4))="",^TMP("SCRPW",$J,2,SDUI,SDPNAM,DFN)=SDX Q

 I SD("SORT")=5 S ^TMP("SCRPW",$J,1,SDS(1),SDS(2),SDS(3),SDS(4))="",^TMP("SCRPW",$J,2,SDUI,SDS(5),SDPNAM,DFN)=SDX Q

 I SD("SORT")=6 S ^TMP("SCRPW",$J,1,SDS(1),SDS(2),SDS(3),SDS(4))="",^TMP("SCRPW",$J,2,SDUI,SDS(5),SDS(6),SDPNAM,DFN)=SDX

 Q

 ;

SORT(SDACR) ;Return sort value

 ;Required input: SDACR=data element acronym

 N SDACT,SDX,SDOE0

 S SDOE0=U_DFN_U,SDACT=^TMP("SCRPW",$J,"ACT",SDACR) X $P(SDACT,T,7)

 S SDX=$O(SDX("")) Q $P(SDX(SDX),U,2)

 ;

STOP ;Check for stop task request

 S:$D(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q

 ;

ASK1 ;Prompt for 'Means Test/Eligibility/Enrollment Report' parameters

 N SD,SDDIV,%DT,X,Y,DIR,SDOUT,SDNUL S (SDOUT,SDNUL,SD("SORT"))=0

 D TITL^SCRPW50("Means Test/Eligibility/Enrollment Report")

 G:'$$DIVA^SCRPW17(.SDDIV) EXIT1^SCRPW42

 D SUBT^SCRPW50("**** Date Range Selection ****")

 W ! S %DT="AEPX",%DT(0)=2961001,%DT("A")="Beginning date: " D ^%DT G:Y<1 EXIT1^SCRPW42 S SD("BDT")=Y X ^DD("DD") S $P(SD("BDT"),U,2)=Y

EDT1 S %DT("A")="   Ending date: " W ! D ^%DT G:Y<1 EXIT1^SCRPW42

 I Y<SD("BDT") W !!,$C(7),"End date cannot be before begin date!",! G EDT1

 S SD("EDT")=Y_.999999 X ^DD("DD") S $P(SD("EDT"),U,2)=Y

 D SUBT^SCRPW50("**** Report Format Selection ****")

 K DIR S DIR(0)="S^D:DETAILED;S:SUMMARY",DIR("A")="Select report format",DIR("?",1)="Specify the format of report you wish to print.  'Detailed' allows the printing",DIR("?")="of patient lists, 'summary' produces totals only."

 S DIR("B")="SUMMARY" D ^DIR G:$D(DTOUT)!$D(DUOUT) EXIT1^SCRPW42 S SD("FMT",1)=Y_U_Y(0)  G:Y="S" STAT

 D SUBT^SCRPW50("**** Detail Category Selection ****")

 K DIR S DIR(0)="S^MT:MEANS TEST INDICATOR;EE:ENCOUNTER ELIGIBILITY;EP:ENROLLMENT PRIORITY",DIR("A")="Select category for detail",DIR("?")="This determines how output will be sorted."

 D ^DIR G:$D(DTOUT)!$D(DUOUT) EXIT1^SCRPW42 S SD("FMT",2)=Y_U_Y(0) D SCAT^SCRPW43 G:'$D(SD("FMT",3))!SDOUT EXIT1^SCRPW42

 S SDNUL=0 D BLD^SCRPW21 S SDX="" D SUBT^SCRPW50("**** Output Sort Selection (optional) ****") S DIR("?")="Sort elements selected will determine the order of output.",(SD("PAGE"),SD("SORT"))=0

 F SDI=1:1:6 S T="~",DIR("A")=$S(SDX="":"Specify data element to sort by",1:"Within "_SDX_", sort by") D ASK^SCRPW41 Q:SDOUT!SDNUL

STAT ;Prompt for encounter statuses to include

 D SUBT^SCRPW50("**** Encounter Status Selection ****")

 K SD("STAT") W !!,"Choose as many of the following statuses",!,"as you wish to include in the report:",!

 W !?10,"CHECKED IN",!?10,"CHECKED OUT",!?10,"NO ACTION TAKEN",!?10,"INPATIENT APPOINTMENT",!?10,"NON-COUNT",!?10,"ACTION REQUIRED",! N DIC,I S DIC="^SD(409.63,",DIC(0)="AEMQ",DIC("B")="CHECKED OUT"

 S DIC("S")="I Y<4!(Y=8!(Y=12!(Y=14)))",DIC("A")="Select encounter status: " F I=1:1 D ^DIC Q:$D(DTOUT)!$D(DUOUT)  S:Y>0 SD("STAT",$P(Y,U))=$P(Y,U,2) K DIC("B") Q:X=""&(I>1)

 G:'$D(SD("STAT")) EXIT1^SCRPW42 D PDIS^SCRPW43 G:SDOUT EXIT1^SCRPW42

 N ZTSAVE S ZTSAVE("SD(")="",ZTSAVE("SDDIV(")="",ZTSAVE("SDDIV")=""

 W:$P(SD("FMT",1),U)="D" !!,"This report requires 132 column output." W ! D EN^XUTMDEVQ("START^SCRPW43","Means Test/Eligibility/Enrollment Report",.ZTSAVE),DISP0^SCRPW23 G EXIT1^SCRPW42

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---SCRPW41   8907     printed  Feb 19, 2025@00:10:09                                                                                                                                                                                                     Page 2

SCRPW41   ;RENO/KEITH - Veterans Without Activity Since a Specified Date Range ; 5/25/2004

 +1       ;;5.3;Scheduling;**144,375,358**;AUG 13, 1993

 +2        NEW DIR,%DT

           KILL SD

 +3        DO TITL^SCRPW50("Veterans Without Activity Since a Specified Date Range")

 +4        WRITE !!,"This report will return a list of veterans that are not deceased who had",!,"activity during a date range specified by the user, and have not been seen"

 +5        WRITE !,"since.  Activity is determined by an examination of Fee Basis, inpatient and",!,"outpatient care (including future appointments).  Once the scheduling"

 +6        WRITE !,"replacement application has been implemented at your site, this report will",!,"no longer be accurate."

 +7        DO SUBT^SCRPW50("**** Date Range Selection ****")

 +8        WRITE !

           SET %DT="AEPX"

           SET %DT("A")="Beginning date: "

           DO ^%DT

           if Y<1

               GOTO EXIT^SCRPW42

           SET SD("BDT")=Y

           XECUTE ^DD("DD")

           SET SD("PBDT")=Y

EDT        SET %DT("A")="   Ending date: "

           WRITE !

           DO ^%DT

           if Y<1

               GOTO EXIT^SCRPW42

 +1        IF Y<SD("BDT")

               WRITE !!,$CHAR(7),"End date cannot be before begin date!",!

               GOTO EDT

 +2        SET SD("EDT")=Y_.999999

           XECUTE ^DD("DD")

           SET SD("PEDT")=Y

           SET (SDOUT,SDNUL)=0

 +3        DO BLD^SCRPW21

           SET SDX=""

           DO SUBT^SCRPW50("**** Output Sort Selection (optional) ****")

           SET DIR("?")="Sort elements selected will determine the order of output."

           SET (SD("PAGE"),SD("SORT"))=0

 +4        FOR SDI=1:1:6

               SET T="~"

               SET DIR("A")=$SELECT(SDX="":"Specify data element to sort by",1:"Within "_SDX_", sort by")

               DO ASK

               if SDOUT!SDNUL

                   QUIT 

 +5        if SDOUT

               GOTO EXIT^SCRPW42

           DO SUBT^SCRPW50("**** Parameters Selected ****")

           WRITE !!,"Veterans not seen since the date range: ",SD("PBDT")," to ",SD("PEDT"),!!,"Output sort elements: "

           Begin DoDot:1

 +6            IF SD("SORT")=0

                   WRITE "(NONE SELECTED)"

                   QUIT 

 +7            SET SDI=0

               FOR 

                   SET SDI=$ORDER(SD("SORT",SDI))

                   if 'SDI

                       QUIT 

                   SET SDX=SD("SORT",SDI)

                   if SDI>1

                       WRITE !

                   WRITE ?(19+(3*SDI))

                   SET SDL=$SELECT($PIECE(SDX,U,3):(69-$X),1:(80-$X))

                   WRITE $EXTRACT($PIECE(SDX,U,2),1,SDL)_$SELECT($PIECE(SDX,U,3):" <pagefeed>",1:"")

 +8            QUIT 

           End DoDot:1

 +9        KILL DIR

           SET DIR(0)="Y"

           SET DIR("A")="Ok"

           SET DIR("B")="YES"

           SET DIR("?")="Specify if the parameters are satisfactory as displayed."

           WRITE !

           DO ^DIR

           if $DATA(DTOUT)!$DATA(DUOUT)

               GOTO EXIT^SCRPW42

           if 'Y

               GOTO EXIT^SCRPW42

 +10       NEW ZTSAVE

           SET ZTSAVE("SD(")=""

           WRITE !!,"This report requires 132 column output.",!

 +11       DO EN^XUTMDEVQ("START^SCRPW41","Veterans Without Activity Since a Specified Date",.ZTSAVE)

           GOTO EXIT^SCRPW42

 +12      ;

ASK       ;Ask for sort elements

 +1        NEW SDZ

           IF $LENGTH(SDX)

               DO SUBT^SCRPW50("**** Select "_$SELECT(SDI=2:"second",SDI=3:"third",SDI=4:"fourth",SDI=5:"fifth",SDI=6:"sixth",1:"another")_" sort element (optional) ****")

 +2        KILL DIR(0)

           SET S1=$$DIR^SCRPW23(.DIR,1,"","","O",2)

           if SDOUT!SDNUL

               QUIT 

 +3        KILL DIR(0)

           SET DIR("A")="Select "_$PIECE(S1,U,2)_" data element"

           SET S2=$$DIR^SCRPW23(.DIR,2,"",$PIECE(S1,U),"O",2,1)

           if SDOUT

               QUIT 

           IF SDNUL

               SET SDNUL=0

               GOTO ASK

 +4        SET SDX=$PIECE(S2,U,2)

           SET SD("SORT",SDI)=$PIECE(S1,U)_$PIECE(S2,U)_U_SDX_U_$$PF()

           SET SD("SORT")=SD("SORT")+1

           QUIT 

 +5       ;

PF()      ;Prompt for page feed

 +1        NEW DIR

           SET DIR(0)="Y"

           SET DIR("A")="Perform a pagefeed for each new "_SDX_" value"

           SET DIR("B")="NO"

           SET DIR("?")="Specify if you want a pagefeed between each sort value for this element."

           WRITE !

           DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)

               SET SDOUT=1

               QUIT 0

 +2        if Y

               SET SD("PAGE")=SDI

           QUIT Y

 +3       ;

START     ;Print report

 +1        KILL ^TMP("SCRPW",$JOB)

           DO BLD^SCRPW21

           SET (SDOUT,SDSTOP,DFN)=0

           DO NOW^%DTC

           SET SDNOW=%

           SET T="~"

 +2        SET SDFEE=""

 +3        FOR 

               SET DFN=$ORDER(^DPT(DFN))

               if 'DFN

                   QUIT 

               SET SDSTOP=SDSTOP+1

               if SDSTOP#3000=0

                   DO STOP

               if SDOUT

                   QUIT 

               IF $$VET()

                   SET SDX=$$EVAL(SD("BDT"),SD("EDT"))

                   if $PIECE(SDX,U)=2

                       DO SET

 +4        if SDOUT

               GOTO EXIT^SCRPW42

           DO NOW^%DTC

           SET Y=%

           XECUTE ^DD("DD")

           SET SDPNOW=$PIECE(Y,":",1,2)

           SET SDLINE=""

           SET $PIECE(SDLINE,"-",133)=""

           SET SDPAGE=1

           SET (SDTOT,SDPG)=0

           GOTO ^SCRPW42

 +5       ;

VET()     ;Vet?  Alive?  Eligible?

 +1       ;deceased

           DO DEM^VADPT

           if VADM(6)

               QUIT 0

 +2       ;veteran

           DO ELIG^VADPT

           if 'VAEL(4)

               QUIT 0

 +3       ;eligible

           QUIT VAEL(5)

 +4       ;

EVAL(SDBD,SDED) ;Evaluate last activity

 +1       ;Required input: SDBD=begin date of date range

 +2       ;Required input: SDED=end date of date range

 +3       ;Output: code^last activity date^location, where 'code'=

 +4       ;        1=activity since date range

 +5       ;        2=activity during date range, none since

 +6       ;        3=no activity during or after date range

 +7        NEW SDDT,SDX,SDXX,SDY

 +8        SET SDX=$ORDER(^SCE("ADFN",DFN,9999999),-1)

           IF SDX

               SET SDY=$ORDER(^SCE("ADFN",DFN,SDX,0))

               SET SDY=$$GETOE^SDOE(SDY)

               SET SDY=$PIECE($GET(^SC(+$PIECE(SDY,U,4),0)),U)

               SET SDDT(SDX)=SDY

 +9        SET SDX=$ORDER(^DPT(DFN,"S",9999999),-1)

           IF SDX

               SET SDY=+$GET(^DPT(DFN,"S",SDX,0))

               SET SDY=$PIECE($GET(^SC(+SDY,0)),U)

               SET SDDT(SDX)=SDY

 +10       SET SDX=$ORDER(^DPT(DFN,"DIS",0))

           IF SDX

               SET SDDT(9999999-SDX)="REGISTRATION"

 +11       SET SDX=$ORDER(^SDV("ADT",DFN,9999999),-1)

           IF SDX

               SET SDDT(SDX)="ADD/EDIT"

 +12      ;S SDX=$O(^FBAAA(DFN,1,9999999),-1) I SDX S SDX=$P($G(^FBAAA(DFN,1,SDX,0)),U) I SDX S SDDT(SDX)="FEE BASIS"

 +13       SET SDXX=$$AUTHL^FBUTL(DFN,,SDBD,"SDX")

           Begin DoDot:1

 +14           IF +SDXX=-1

                   IF $PIECE(SDXX,"^",2)=110

                       SET SDFEE="FEE BASIS SYSTEM NOT AVAILABLE"

 +15           IF SDXX>0

                   SET SDDT($GET(SDX(SDXX,"FDT")))="FEE BASIS"

           End DoDot:1

 +16       SET SDX=$ORDER(^DGPM("APRD",DFN,9999999),-1)

           IF SDX

               SET SDY=$ORDER(^DGPM("APRD",DFN,SDX,0))

               SET SDY=$GET(^DGPM(+SDY,0))

               IF $LENGTH(SDY)

                   Begin DoDot:1

 +17                   IF $PIECE(SDY,U,2)=1

                           SET SDDT(SDX)=$PIECE($GET(^DIC(42,+$PIECE(SDY,U,6),0)),U)

                           QUIT 

 +18                   IF $PIECE(SDY,U,2)=3

                           NEW D0,X

                           SET D0=$ORDER(^DGPM("APRD",DFN,SDX,0))

                           DO WARD^DGPMUTL

                           SET SDDT(SDX)=X

                           QUIT 

 +19                   DO WARD(SDX)

                       QUIT 

                   End DoDot:1

 +20       DO WARD(SDNOW)

 +21       SET SDX=$ORDER(SDDT(9999999),-1)

           SET SDX=$SELECT('$LENGTH(SDX):U_U,1:U_SDX_U_SDDT(SDX))

 +22       if $PIECE(SDX,U,2)'<SDED

               QUIT 1_SDX

           if $PIECE(SDX,U,2)'<SDBD

               QUIT 2_SDX

           QUIT 3_SDX

 +23      ;

WARD(SDT) ;Get ward for date/time

 +1       ;Required input: SDT=date/time

 +2        NEW DGT,DG1,DGA1,DGXFR0

           SET DGT=SDT

           DO ^DGPMSTAT

           IF DG1

               SET SDDT(SDT)=$PIECE($GET(^DIC(42,DG1,0)),U)

 +3        QUIT 

 +4       ;

SET       ;Set TMP global

 +1        SET SD0=$GET(^DPT(DFN,0))

           SET SDSSN=$PIECE(SD0,U,9)

           SET SDPNAM=$PIECE(SD0,U)

           if '$LENGTH(SDPNAM)

               QUIT 

           SET $PIECE(SDX,U)=SDSSN

 +2        NEW SDS

           IF SD("SORT")

               SET SDI=""

               FOR 

                   SET SDI=$ORDER(SD("SORT",SDI))

                   if 'SDI

                       QUIT 

                   SET SDS(SDI)=$$SORT($PIECE(SD("SORT",SDI),U))

 +3        IF 'SD("SORT")

               SET ^TMP("SCRPW",$JOB,1,SDPNAM,DFN)=SDX

               QUIT 

 +4        IF SD("SORT")=1

               SET ^TMP("SCRPW",$JOB,1,SDS(1),SDPNAM,DFN)=SDX

               QUIT 

 +5        IF SD("SORT")=2

               SET ^TMP("SCRPW",$JOB,1,SDS(1),SDS(2),SDPNAM,DFN)=SDX

               QUIT 

 +6        IF SD("SORT")=3

               SET ^TMP("SCRPW",$JOB,1,SDS(1),SDS(2),SDS(3),SDPNAM,DFN)=SDX

               QUIT 

 +7        SET SDUI=$$DSV^SCRPW42(SDS(1),SDS(2),SDS(3),SDS(4))

 +8        IF SD("SORT")=4

               SET ^TMP("SCRPW",$JOB,1,SDS(1),SDS(2),SDS(3),SDS(4))=""

               SET ^TMP("SCRPW",$JOB,2,SDUI,SDPNAM,DFN)=SDX

               QUIT 

 +9        IF SD("SORT")=5

               SET ^TMP("SCRPW",$JOB,1,SDS(1),SDS(2),SDS(3),SDS(4))=""

               SET ^TMP("SCRPW",$JOB,2,SDUI,SDS(5),SDPNAM,DFN)=SDX

               QUIT 

 +10       IF SD("SORT")=6

               SET ^TMP("SCRPW",$JOB,1,SDS(1),SDS(2),SDS(3),SDS(4))=""

               SET ^TMP("SCRPW",$JOB,2,SDUI,SDS(5),SDS(6),SDPNAM,DFN)=SDX

 +11       QUIT 

 +12      ;

SORT(SDACR) ;Return sort value

 +1       ;Required input: SDACR=data element acronym

 +2        NEW SDACT,SDX,SDOE0

 +3        SET SDOE0=U_DFN_U

           SET SDACT=^TMP("SCRPW",$JOB,"ACT",SDACR)

           XECUTE $PIECE(SDACT,T,7)

 +4        SET SDX=$ORDER(SDX(""))

           QUIT $PIECE(SDX(SDX),U,2)

 +5       ;

STOP      ;Check for stop task request

 +1        if $DATA(ZTQUEUED)

               SET (SDOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)

           QUIT 

 +2       ;

ASK1      ;Prompt for 'Means Test/Eligibility/Enrollment Report' parameters

 +1        NEW SD,SDDIV,%DT,X,Y,DIR,SDOUT,SDNUL

           SET (SDOUT,SDNUL,SD("SORT"))=0

 +2        DO TITL^SCRPW50("Means Test/Eligibility/Enrollment Report")

 +3        if '$$DIVA^SCRPW17(.SDDIV)

               GOTO EXIT1^SCRPW42

 +4        DO SUBT^SCRPW50("**** Date Range Selection ****")

 +5        WRITE !

           SET %DT="AEPX"

           SET %DT(0)=2961001

           SET %DT("A")="Beginning date: "

           DO ^%DT

           if Y<1

               GOTO EXIT1^SCRPW42

           SET SD("BDT")=Y

           XECUTE ^DD("DD")

           SET $PIECE(SD("BDT"),U,2)=Y

EDT1       SET %DT("A")="   Ending date: "

           WRITE !

           DO ^%DT

           if Y<1

               GOTO EXIT1^SCRPW42

 +1        IF Y<SD("BDT")

               WRITE !!,$CHAR(7),"End date cannot be before begin date!",!

               GOTO EDT1

 +2        SET SD("EDT")=Y_.999999

           XECUTE ^DD("DD")

           SET $PIECE(SD("EDT"),U,2)=Y

 +3        DO SUBT^SCRPW50("**** Report Format Selection ****")

 +4        KILL DIR

           SET DIR(0)="S^D:DETAILED;S:SUMMARY"

           SET DIR("A")="Select report format"

           SET DIR("?",1)="Specify the format of report you wish to print.  'Detailed' allows the printing"

           SET DIR("?")="of patient lists, 'summary' produces totals only."

 +5        SET DIR("B")="SUMMARY"

           DO ^DIR

           if $DATA(DTOUT)!$DATA(DUOUT)

               GOTO EXIT1^SCRPW42

           SET SD("FMT",1)=Y_U_Y(0)

           if Y="S"

               GOTO STAT

 +6        DO SUBT^SCRPW50("**** Detail Category Selection ****")

 +7        KILL DIR

           SET DIR(0)="S^MT:MEANS TEST INDICATOR;EE:ENCOUNTER ELIGIBILITY;EP:ENROLLMENT PRIORITY"

           SET DIR("A")="Select category for detail"

           SET DIR("?")="This determines how output will be sorted."

 +8        DO ^DIR

           if $DATA(DTOUT)!$DATA(DUOUT)

               GOTO EXIT1^SCRPW42

           SET SD("FMT",2)=Y_U_Y(0)

           DO SCAT^SCRPW43

           if '$DATA(SD("FMT",3))!SDOUT

               GOTO EXIT1^SCRPW42

 +9        SET SDNUL=0

           DO BLD^SCRPW21

           SET SDX=""

           DO SUBT^SCRPW50("**** Output Sort Selection (optional) ****")

           SET DIR("?")="Sort elements selected will determine the order of output."

           SET (SD("PAGE"),SD("SORT"))=0

 +10       FOR SDI=1:1:6

               SET T="~"

               SET DIR("A")=$SELECT(SDX="":"Specify data element to sort by",1:"Within "_SDX_", sort by")

               DO ASK^SCRPW41

               if SDOUT!SDNUL

                   QUIT 

STAT      ;Prompt for encounter statuses to include

 +1        DO SUBT^SCRPW50("**** Encounter Status Selection ****")

 +2        KILL SD("STAT")

           WRITE !!,"Choose as many of the following statuses",!,"as you wish to include in the report:",!

 +3        WRITE !?10,"CHECKED IN",!?10,"CHECKED OUT",!?10,"NO ACTION TAKEN",!?10,"INPATIENT APPOINTMENT",!?10,"NON-COUNT",!?10,"ACTION REQUIRED",!

           NEW DIC,I

           SET DIC="^SD(409.63,"

           SET DIC(0)="AEMQ"

           SET DIC("B")="CHECKED OUT"

 +4        SET DIC("S")="I Y<4!(Y=8!(Y=12!(Y=14)))"

           SET DIC("A")="Select encounter status: "

           FOR I=1:1

               DO ^DIC

               if $DATA(DTOUT)!$DATA(DUOUT)

                   QUIT 

               if Y>0

                   SET SD("STAT",$PIECE(Y,U))=$PIECE(Y,U,2)

               KILL DIC("B")

               if X=""&(I>1)

                   QUIT 

 +5        if '$DATA(SD("STAT"))

               GOTO EXIT1^SCRPW42

           DO PDIS^SCRPW43

           if SDOUT

               GOTO EXIT1^SCRPW42

 +6        NEW ZTSAVE

           SET ZTSAVE("SD(")=""

           SET ZTSAVE("SDDIV(")=""

           SET ZTSAVE("SDDIV")=""

 +7        if $PIECE(SD("FMT",1),U)="D"

               WRITE !!,"This report requires 132 column output."

           WRITE !

           DO EN^XUTMDEVQ("START^SCRPW43","Means Test/Eligibility/Enrollment Report",.ZTSAVE)

           DO DISP0^SCRPW23

           GOTO EXIT1^SCRPW42