DGPOTEN ;SLC/RM/JC - POTENTIAL PRESUMPTIVE PSYCHOSIS REPORT ; Apr 1, 2021@12:54:25 pm
;;5.3;Registration;**1047**;Aug 13, 1993;Build 13
;
Q
;
;Main entry point for PRESUMPTIVE PSYCHOSIS POTENTIAL REPORT option
MAIN ;
N DGSORT ;array of report parameters
N ZTDESC,ZTQUEUED,ZTREQ,ZTSAVE,ZTSTOP
W @IOF
W "POTENTIAL PRESUMPTIVE PSYCHOSIS REPORT"
W !!,"This option generates a list of patients who have been registered in"
W !,"VistA using the Presumptive Psychosis 'workaround' since 38 U.S. Code"
W !,"1702 was passed on 3/14/2013."
W !!,"Registration/Eligibility staff can use this list to view patient"
W !,"registrations to assign the Presumptive Psychosis Indicator found in"
W !,"VistA screen 7, if applicable."
W !!,"The default start date is the date the United State Code was put into"
W !,"effect; however, you can select a later start date.",!
W !,"You can also select a different end date for the report. Default is TODAY.",!
;Prompt user for FROM Date of Eligibility Change
I '$$DATEFROM Q
;Prompt user for TO Date of Eligibility Change
I '$$DATETO Q
;prompt for device
W !
S ZTSAVE("DGSORT(")=""
S X="POTENTIAL PRESUMPTIVE PSYCHOSIS PATIENT REPORT"
D EN^XUTMDEVQ("START^DGPOTEN",X,.ZTSAVE) ;JMC
D HOME^%ZIS
Q
;
START ; compile and print report
I $E(IOST)="C" D WAIT^DICD
N HERE S HERE=$$SITE^VASITE ;extract the IEN and facility name where the report is run
N TRM S TRM=($E(IOST)="C")
N DGPOTENLST ;temp data storage used for PP Potential report list
N RECORD,IBOTHSTAT ;JMC
S DGPOTENLST=$NA(^TMP($J,"DGPPPOTEN")) ;contains all PP data to be displayed in the report
S RECORD=$NA(^TMP($J,"DGPOTENREC")) ;contains all PP episodes of care data found in file #409.68,#52,#405,#45,#350,#399
S IBOTHSTAT=$NA(^TMP($J,"DGPPIBPOTEN")) ;contains file #350,#399 ;JMC
K @DGPOTENLST,@RECORD,@IBOTHSTAT ;JMC
D LOOP(.DGSORT,DGPOTENLST)
D PRINTPP(.DGSORT,DGPOTENLST)
K @DGPOTENLST,@RECORD,@IBOTHSTAT ;JMC
D EXIT
Q
;
LOOP(DGSORT,DGPOTENLST) ;
N DGDFN,VAUTD,SORTENCBY,CPT,DGPTNAME,DGPID,DGDOB,DGENCNT,DGPPWRK,DGPPCAT
N VAEL,VADM,DGDOD,DATA,VA,DFN,I,I1,DGPPFLGRPT,DGPPREGDT,DGLASTEOC
S SORTENCBY=0
;PP VA Workaround
; Registration Screen <7>
; - Patient Type: SC Veteran
; - Veteran : Yes
; - Service Connected: Yes
; - Service Connected %: 0%
; - Primary Elig Code: SC LESS THAN 50%
; - Other Elig Code(s): HUMANITARIAN EMERGENCY
; Registration Screen <5>
; - VHA DIRECTIVE 1029 WNR (This is a Free text for insurance buffer entry)
; Registration Screen <11>
; - Select RATED DISABILITIES (VA): 9410
; - DISABILITY %: 0
; and/or with
; Registration Screen <7>
; - PP Indicator (SHRPE 1.0)
;Please Note:
; This report will not filter the facility/division of the episodes of care where the report is run
; It will display all facility/division regardless
S VAUTD=1 ;All the divisions in the facility, since we are not prompting user to enter Division
S DGPPFLGRPT=1 ;this flag will be used to determine which mumps code to execute in DGFSMOUT routine
;Loop through all PATIENT file #2
S (DGDFN,CPT)=0 F S DGDFN=$O(^DPT(DGDFN)) Q:'DGDFN D
. S CPT=CPT+1 W:'(CPT#60000) "." ;write . every 60,000 processed records
. S DGPPCAT=$$PPINFO^DGPPAPI(DGDFN)
. Q:$P(DGPPCAT,U)="Y" ;patients with PP category will not be included into the report
. S DGPPWRK=$$PPWRKARN^DGPPAPI(DGDFN) ;check if this patient is registered correctly using PP VA workaround settings
. I $P(DGPPCAT,U)'="Y" S DGPPCAT="N"
. I DGPPWRK="Y",DGPPCAT="N" D ;if PP VA Workaround exist, extract episode of care/inpatient/bill charges/rx
. . K @RECORD ;evaluate each patient one at a time
. . S (DGENCNT,I1,I)=0
. . S DGPTNAME=$$GET1^DIQ(2,DGDFN_",",.01,"E")
. . S DGPID=$$GET1^DIQ(2,DGDFN_",",.0905,"I")
. . S DGPPREGDT=$$GET1^DIQ(2,DGDFN_",",.097,"I") ;Vista Registration Entry
. . S DGLASTEOC=$$LASTEOC(DGDFN)
. . S DGDOD=$$GET1^DIQ(2,DGDFN_",",.351,"I")\1 ;date of death
. . S DATA=DGPTNAME_U_DGPID_U_DGPPREGDT_U_DGLASTEOC_U_$S(+DGDOD<1:"N/A",1:DGDOD)
. . I $G(DGLASTEOC)="NO DATA FOUND" Q ;JMC Prevents either out of range or no data found from appearing on report.
. . S @DGPOTENLST@(DGPTNAME,DGDFN)=DATA
Q
;
LASTEOC(DFN) ;extract all Episode of Care and Rx and return the most current Episode of Care for a patient
N DGLASTEOC
D CHKTREAT^DGFSMOUT(+DFN,DGSORT("DGBEG"),DGSORT("DGEND"),.VAUTD,0) ;check if there any past Outpatient Encounter entry in file #409.68
D CHECKPTF^DGFSMOUT(DFN,DGSORT("DGBEG"),DGSORT("DGEND"),"DGPPIBPOTEN") ;check if there any Inpatient stay entry in file #405
D CHECKIB^DGFSMOUT("DGPPIBPOTEN",DGSORT("DGBEG"),DGSORT("DGEND")) K ^TMP($J,"DGPPIBPOTEN") ;check if this patient has records in file #350 or file #399
D CHECKRX^DGFSMOUT("DGPPRXPOTEN") ;check at file #52 if this patient has any RX not yet charged
I $O(@RECORD@(""))="" S DGLASTEOC="NO DATA FOUND"
E D PPDATE
I DGLASTEOC<DGSORT("DGBEG") S DGLASTEOC="NO DATA FOUND"
I DGLASTEOC>DGSORT("DGEND") S DGLASTEOC="NO DATA FOUND"
Q DGLASTEOC
;
PPDATE ;
N DGDOS,DGSTATN,FILENO,CNT,PPDTARY
S DGLASTEOC=0
S DGDOS="" F S DGDOS=$O(@RECORD@(DGDOS)) Q:DGDOS="" D
. S DGSTATN="" F S DGSTATN=$O(@RECORD@(DGDOS,DGSTATN)) Q:DGSTATN="" D
. . S FILENO="" F S FILENO=$O(@RECORD@(DGDOS,DGSTATN,FILENO)) Q:FILENO="" D
. . . S CNT="" F S CNT=$O(@RECORD@(DGDOS,DGSTATN,FILENO,CNT)) Q:CNT="" D
. . . . I '$D(PPDTARY(DGDOS\1))="" S DGLASTEOC=DGDOS\1
. . . . E I DGLASTEOC<DGDOS\1 S DGLASTEOC=DGDOS\1
Q
;
PRINTPP(DGSORT,DGPOTENLST) ;
N DGPAGE,DDASH,DGQ,DGDFN,DGTOTAL,DGPRINT,DGOLD,DGSTATN,DGPTNAME,DGLSTEOC,DGDOD,DGDTOFREG
S (DGQ,DGTOTAL,DGPAGE,DGPRINT,DGOLD)=0,$P(DDASH,"=",81)=""
I $O(@DGPOTENLST@(""))="" D Q
. D HEADER,COLHEAD
. W !!!," >>> No records were found using the report criteria.",!!
. W ! D LINE
. D ASKCONT(0)
; loop and print report
D HEADER,COLHEAD
S DGPTNAME="" F S DGPTNAME=$O(@DGPOTENLST@(DGPTNAME)) Q:DGPTNAME="" D Q:DGQ
. S DGDFN="" F S DGDFN=$O(@DGPOTENLST@(DGPTNAME,DGDFN)) Q:DGDFN="" D Q:DGQ
. . I $Y>(IOSL-4) W ! D PAUSE(.DGQ) Q:DGQ D HEADER,COLHEAD
. . S DGDTOFREG=$P(@DGPOTENLST@(DGPTNAME,DGDFN),U,3)
. . W $E(DGPTNAME,1,30),?32,$P(@DGPOTENLST@(DGPTNAME,DGDFN),U,2),?39,$S(DGDTOFREG'="":$$FMTE^XLFDT(DGDTOFREG,"5Z"),1:"NONE ENTERED")
. . S DGLSTEOC=$P(@DGPOTENLST@(DGPTNAME,DGDFN),U,4)
. . I DGLSTEOC'?.N W ?53,DGLSTEOC
. . E W ?53,$$FMTE^XLFDT(DGLSTEOC,"5Z")
. . S DGDOD=$P(@DGPOTENLST@(DGPTNAME,DGDFN),U,5)
. . I DGDOD'?.N W ?69,DGDOD
. . E W ?69,$$FMTE^XLFDT(DGDOD\1,"5Z")
. . W !
. . S DGTOTAL=DGTOTAL+1
. Q:DGQ
Q:DGQ
D LINE
W !!,"Number of Unique Patients: ",$J(DGTOTAL,5)
W !!,"<< end of report >>"
D ASKCONT(0) W @IOF
Q
;
;
N DGFACLTY,DGDTRNGE,DTPRNTD
I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQ)=1 Q
I TRM!('TRM&DGPAGE) W @IOF
S DGPAGE=$G(DGPAGE)+1
W "REPORT RUN DATE: ",$$FMTE^XLFDT($$NOW^XLFDT,"MP")
W ?44,"DATE RANGE: ",$$FMTE^XLFDT(DGSORT("DGBEG"),"5Z")," TO ",$$FMTE^XLFDT(DGSORT("DGEND"),"5Z")
W ! D LINE W !
W ?(80-$L(ZTDESC))\2,$G(ZTDESC),?70,"Page: ",DGPAGE
S DGFACLTY="FACILITY: "_$P(HERE,U,2)
W !,?(80-$L(DGFACLTY))\2,DGFACLTY
W ! D LINE W !
Q
;
LINE ;prints double dash line
N LINE
F LINE=1:1:80 W "="
Q
;
COLHEAD ;report column header
W "PATIENT NAME",?32,"PID",?39,"REGISTRATION",?53,"LAST EPISODE",?69,"DATE OF"
W !,?39,"DATE",?53,"OF CARE",?69,"DEATH"
W ! D LINE W !
Q
;
ASKCONT(FLAG) ; display "press <Enter> to continue" prompt
N Z
W !!,$$CJ^XLFSTR("Press <Enter> to "_$S(FLAG=1:"continue.",1:"exit."),20)
R !,Z:DTIME
Q
;
PAUSE(DGQ) ; pause screen display
; Input:
; DGQ - var used to quit report processing to user CRT
; Output:
; DGQ - passed by reference - 0 = Continue, 1 = Quit
;
I $G(DGPAGE)>0,TRM K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQ=1
Q
;
EXIT ;
Q
;
DATEFROM() ;prompt for FROM Date of Service
N DGASK,DGDIRA,DGDIRB,DGDIRH,DGDIRO,DGBEGDT,DGSTRTDT
S DGBEGDT=3130314 ;03/14/2013 - Presumptive Psychosis legislation date
S DGDIRA=" Start with Date: "
S DGDIRB=$$FMTE^XLFDT(DGBEGDT)
S DGDIRH="^D HELP^DGPPRRPT(1)"
S DGDIRO="DA^"_DGBEGDT_":DT:EX"
S DGASK=$$ANSWER(DGDIRA,DGDIRB,DGDIRO,DGDIRH)
I DGASK>0 S DGSORT("DGBEG")=$S(DGASK<DGBEGDT:DGBEGDT,1:DGASK)
Q DGASK>0
;
DATETO() ;prompt for TO Date of Service
N DGASK,DGDIRA,DGDIRB,DGDIRH,DGDIRO,DGDTEND
S DGDIRA=" End with Date : "
S DGDIRB="TODAY"
S DGDIRH="^D HELP^DGPPRRPT(1)"
S DGDTEND=DGSORT("DGBEG")
S DGDIRO="DA^"_DGSORT("DGBEG")_":DT:EX"
S DGASK=$$ANSWER(DGDIRA,DGDIRB,DGDIRO,DGDIRH)
I DGASK>0 S DGSORT("DGEND")=DGASK
Q DGASK>0
;
ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH) ;
; Input
; DGDIR0 - DIR(0) string
; DGDIRA - DIR("A") string
; DGDIRB - DIR("B") string
; DGDIRH - DIR("?") string
; Output
; Function Value - Internal value returned from ^DIR or -1 if user
; up-arrows, double up-arrows or the read times out.
N X,Y,Z,DIR,DIROUT,DIRUT,DTOUT,DUOUT
I $D(DGDIR0) S DIR(0)=DGDIR0
I $D(DGDIRA) M DIR("A")=DGDIRA
I $G(DGDIRB)]"" S DIR("B")=DGDIRB
I $D(DGDIRH) S DIR("?")=DGDIRH,DIR("??")=DGDIRH
D ^DIR K DIR
S Z=$S($D(DTOUT):-2,$D(DUOUT):-1,$D(DIROUT):-1,1:"")
I Z="" S Z=$S(Y=-1:"",X="@":"@",1:$P(Y,U)) Q Z
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1
Q $S(X="@":"@",1:$P(Y,U))
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPOTEN 9437 printed Sep 23, 2025@20:26:39 Page 2
DGPOTEN ;SLC/RM/JC - POTENTIAL PRESUMPTIVE PSYCHOSIS REPORT ; Apr 1, 2021@12:54:25 pm
+1 ;;5.3;Registration;**1047**;Aug 13, 1993;Build 13
+2 ;
+3 QUIT
+4 ;
+5 ;Main entry point for PRESUMPTIVE PSYCHOSIS POTENTIAL REPORT option
MAIN ;
+1 ;array of report parameters
NEW DGSORT
+2 NEW ZTDESC,ZTQUEUED,ZTREQ,ZTSAVE,ZTSTOP
+3 WRITE @IOF
+4 WRITE "POTENTIAL PRESUMPTIVE PSYCHOSIS REPORT"
+5 WRITE !!,"This option generates a list of patients who have been registered in"
+6 WRITE !,"VistA using the Presumptive Psychosis 'workaround' since 38 U.S. Code"
+7 WRITE !,"1702 was passed on 3/14/2013."
+8 WRITE !!,"Registration/Eligibility staff can use this list to view patient"
+9 WRITE !,"registrations to assign the Presumptive Psychosis Indicator found in"
+10 WRITE !,"VistA screen 7, if applicable."
+11 WRITE !!,"The default start date is the date the United State Code was put into"
+12 WRITE !,"effect; however, you can select a later start date.",!
+13 WRITE !,"You can also select a different end date for the report. Default is TODAY.",!
+14 ;Prompt user for FROM Date of Eligibility Change
+15 IF '$$DATEFROM
QUIT
+16 ;Prompt user for TO Date of Eligibility Change
+17 IF '$$DATETO
QUIT
+18 ;prompt for device
+19 WRITE !
+20 SET ZTSAVE("DGSORT(")=""
+21 SET X="POTENTIAL PRESUMPTIVE PSYCHOSIS PATIENT REPORT"
+22 ;JMC
DO EN^XUTMDEVQ("START^DGPOTEN",X,.ZTSAVE)
+23 DO HOME^%ZIS
+24 QUIT
+25 ;
START ; compile and print report
+1 IF $EXTRACT(IOST)="C"
DO WAIT^DICD
+2 ;extract the IEN and facility name where the report is run
NEW HERE
SET HERE=$$SITE^VASITE
+3 NEW TRM
SET TRM=($EXTRACT(IOST)="C")
+4 ;temp data storage used for PP Potential report list
NEW DGPOTENLST
+5 ;JMC
NEW RECORD,IBOTHSTAT
+6 ;contains all PP data to be displayed in the report
SET DGPOTENLST=$NAME(^TMP($JOB,"DGPPPOTEN"))
+7 ;contains all PP episodes of care data found in file #409.68,#52,#405,#45,#350,#399
SET RECORD=$NAME(^TMP($JOB,"DGPOTENREC"))
+8 ;contains file #350,#399 ;JMC
SET IBOTHSTAT=$NAME(^TMP($JOB,"DGPPIBPOTEN"))
+9 ;JMC
KILL @DGPOTENLST,@RECORD,@IBOTHSTAT
+10 DO LOOP(.DGSORT,DGPOTENLST)
+11 DO PRINTPP(.DGSORT,DGPOTENLST)
+12 ;JMC
KILL @DGPOTENLST,@RECORD,@IBOTHSTAT
+13 DO EXIT
+14 QUIT
+15 ;
LOOP(DGSORT,DGPOTENLST) ;
+1 NEW DGDFN,VAUTD,SORTENCBY,CPT,DGPTNAME,DGPID,DGDOB,DGENCNT,DGPPWRK,DGPPCAT
+2 NEW VAEL,VADM,DGDOD,DATA,VA,DFN,I,I1,DGPPFLGRPT,DGPPREGDT,DGLASTEOC
+3 SET SORTENCBY=0
+4 ;PP VA Workaround
+5 ; Registration Screen <7>
+6 ; - Patient Type: SC Veteran
+7 ; - Veteran : Yes
+8 ; - Service Connected: Yes
+9 ; - Service Connected %: 0%
+10 ; - Primary Elig Code: SC LESS THAN 50%
+11 ; - Other Elig Code(s): HUMANITARIAN EMERGENCY
+12 ; Registration Screen <5>
+13 ; - VHA DIRECTIVE 1029 WNR (This is a Free text for insurance buffer entry)
+14 ; Registration Screen <11>
+15 ; - Select RATED DISABILITIES (VA): 9410
+16 ; - DISABILITY %: 0
+17 ; and/or with
+18 ; Registration Screen <7>
+19 ; - PP Indicator (SHRPE 1.0)
+20 ;Please Note:
+21 ; This report will not filter the facility/division of the episodes of care where the report is run
+22 ; It will display all facility/division regardless
+23 ;All the divisions in the facility, since we are not prompting user to enter Division
SET VAUTD=1
+24 ;this flag will be used to determine which mumps code to execute in DGFSMOUT routine
SET DGPPFLGRPT=1
+25 ;Loop through all PATIENT file #2
+26 SET (DGDFN,CPT)=0
FOR
SET DGDFN=$ORDER(^DPT(DGDFN))
if 'DGDFN
QUIT
Begin DoDot:1
+27 ;write . every 60,000 processed records
SET CPT=CPT+1
if '(CPT#60000)
WRITE "."
+28 SET DGPPCAT=$$PPINFO^DGPPAPI(DGDFN)
+29 ;patients with PP category will not be included into the report
if $PIECE(DGPPCAT,U)="Y"
QUIT
+30 ;check if this patient is registered correctly using PP VA workaround settings
SET DGPPWRK=$$PPWRKARN^DGPPAPI(DGDFN)
+31 IF $PIECE(DGPPCAT,U)'="Y"
SET DGPPCAT="N"
+32 ;if PP VA Workaround exist, extract episode of care/inpatient/bill charges/rx
IF DGPPWRK="Y"
IF DGPPCAT="N"
Begin DoDot:2
+33 ;evaluate each patient one at a time
KILL @RECORD
+34 SET (DGENCNT,I1,I)=0
+35 SET DGPTNAME=$$GET1^DIQ(2,DGDFN_",",.01,"E")
+36 SET DGPID=$$GET1^DIQ(2,DGDFN_",",.0905,"I")
+37 ;Vista Registration Entry
SET DGPPREGDT=$$GET1^DIQ(2,DGDFN_",",.097,"I")
+38 SET DGLASTEOC=$$LASTEOC(DGDFN)
+39 ;date of death
SET DGDOD=$$GET1^DIQ(2,DGDFN_",",.351,"I")\1
+40 SET DATA=DGPTNAME_U_DGPID_U_DGPPREGDT_U_DGLASTEOC_U_$SELECT(+DGDOD<1:"N/A",1:DGDOD)
+41 ;JMC Prevents either out of range or no data found from appearing on report.
IF $GET(DGLASTEOC)="NO DATA FOUND"
QUIT
+42 SET @DGPOTENLST@(DGPTNAME,DGDFN)=DATA
End DoDot:2
End DoDot:1
+43 QUIT
+44 ;
LASTEOC(DFN) ;extract all Episode of Care and Rx and return the most current Episode of Care for a patient
+1 NEW DGLASTEOC
+2 ;check if there any past Outpatient Encounter entry in file #409.68
DO CHKTREAT^DGFSMOUT(+DFN,DGSORT("DGBEG"),DGSORT("DGEND"),.VAUTD,0)
+3 ;check if there any Inpatient stay entry in file #405
DO CHECKPTF^DGFSMOUT(DFN,DGSORT("DGBEG"),DGSORT("DGEND"),"DGPPIBPOTEN")
+4 ;check if this patient has records in file #350 or file #399
DO CHECKIB^DGFSMOUT("DGPPIBPOTEN",DGSORT("DGBEG"),DGSORT("DGEND"))
KILL ^TMP($JOB,"DGPPIBPOTEN")
+5 ;check at file #52 if this patient has any RX not yet charged
DO CHECKRX^DGFSMOUT("DGPPRXPOTEN")
+6 IF $ORDER(@RECORD@(""))=""
SET DGLASTEOC="NO DATA FOUND"
+7 IF '$TEST
DO PPDATE
+8 IF DGLASTEOC<DGSORT("DGBEG")
SET DGLASTEOC="NO DATA FOUND"
+9 IF DGLASTEOC>DGSORT("DGEND")
SET DGLASTEOC="NO DATA FOUND"
+10 QUIT DGLASTEOC
+11 ;
PPDATE ;
+1 NEW DGDOS,DGSTATN,FILENO,CNT,PPDTARY
+2 SET DGLASTEOC=0
+3 SET DGDOS=""
FOR
SET DGDOS=$ORDER(@RECORD@(DGDOS))
if DGDOS=""
QUIT
Begin DoDot:1
+4 SET DGSTATN=""
FOR
SET DGSTATN=$ORDER(@RECORD@(DGDOS,DGSTATN))
if DGSTATN=""
QUIT
Begin DoDot:2
+5 SET FILENO=""
FOR
SET FILENO=$ORDER(@RECORD@(DGDOS,DGSTATN,FILENO))
if FILENO=""
QUIT
Begin DoDot:3
+6 SET CNT=""
FOR
SET CNT=$ORDER(@RECORD@(DGDOS,DGSTATN,FILENO,CNT))
if CNT=""
QUIT
Begin DoDot:4
+7 IF '$DATA(PPDTARY(DGDOS\1))=""
SET DGLASTEOC=DGDOS\1
+8 IF '$TEST
IF DGLASTEOC<DGDOS\1
SET DGLASTEOC=DGDOS\1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
PRINTPP(DGSORT,DGPOTENLST) ;
+1 NEW DGPAGE,DDASH,DGQ,DGDFN,DGTOTAL,DGPRINT,DGOLD,DGSTATN,DGPTNAME,DGLSTEOC,DGDOD,DGDTOFREG
+2 SET (DGQ,DGTOTAL,DGPAGE,DGPRINT,DGOLD)=0
SET $PIECE(DDASH,"=",81)=""
+3 IF $ORDER(@DGPOTENLST@(""))=""
Begin DoDot:1
+4 DO HEADER
DO COLHEAD
+5 WRITE !!!," >>> No records were found using the report criteria.",!!
+6 WRITE !
DO LINE
+7 DO ASKCONT(0)
End DoDot:1
QUIT
+8 ; loop and print report
+9 DO HEADER
DO COLHEAD
+10 SET DGPTNAME=""
FOR
SET DGPTNAME=$ORDER(@DGPOTENLST@(DGPTNAME))
if DGPTNAME=""
QUIT
Begin DoDot:1
+11 SET DGDFN=""
FOR
SET DGDFN=$ORDER(@DGPOTENLST@(DGPTNAME,DGDFN))
if DGDFN=""
QUIT
Begin DoDot:2
+12 IF $Y>(IOSL-4)
WRITE !
DO PAUSE(.DGQ)
if DGQ
QUIT
DO HEADER
DO COLHEAD
+13 SET DGDTOFREG=$PIECE(@DGPOTENLST@(DGPTNAME,DGDFN),U,3)
+14 WRITE $EXTRACT(DGPTNAME,1,30),?32,$PIECE(@DGPOTENLST@(DGPTNAME,DGDFN),U,2),?39,$SELECT(DGDTOFREG'="":$$FMTE^XLFDT(DGDTOFREG,"5Z"),1:"NONE ENTERED")
+15 SET DGLSTEOC=$PIECE(@DGPOTENLST@(DGPTNAME,DGDFN),U,4)
+16 IF DGLSTEOC'?.N
WRITE ?53,DGLSTEOC
+17 IF '$TEST
WRITE ?53,$$FMTE^XLFDT(DGLSTEOC,"5Z")
+18 SET DGDOD=$PIECE(@DGPOTENLST@(DGPTNAME,DGDFN),U,5)
+19 IF DGDOD'?.N
WRITE ?69,DGDOD
+20 IF '$TEST
WRITE ?69,$$FMTE^XLFDT(DGDOD\1,"5Z")
+21 WRITE !
+22 SET DGTOTAL=DGTOTAL+1
End DoDot:2
if DGQ
QUIT
+23 if DGQ
QUIT
End DoDot:1
if DGQ
QUIT
+24 if DGQ
QUIT
+25 DO LINE
+26 WRITE !!,"Number of Unique Patients: ",$JUSTIFY(DGTOTAL,5)
+27 WRITE !!,"<< end of report >>"
+28 DO ASKCONT(0)
WRITE @IOF
+29 QUIT
+30 ;
+1 ;
+2 NEW DGFACLTY,DGDTRNGE,DTPRNTD
+3 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,DGQ)=1
QUIT
+4 IF TRM!('TRM&DGPAGE)
WRITE @IOF
+5 SET DGPAGE=$GET(DGPAGE)+1
+6 WRITE "REPORT RUN DATE: ",$$FMTE^XLFDT($$NOW^XLFDT,"MP")
+7 WRITE ?44,"DATE RANGE: ",$$FMTE^XLFDT(DGSORT("DGBEG"),"5Z")," TO ",$$FMTE^XLFDT(DGSORT("DGEND"),"5Z")
+8 WRITE !
DO LINE
WRITE !
+9 WRITE ?(80-$LENGTH(ZTDESC))\2,$GET(ZTDESC),?70,"Page: ",DGPAGE
+10 SET DGFACLTY="FACILITY: "_$PIECE(HERE,U,2)
+11 WRITE !,?(80-$LENGTH(DGFACLTY))\2,DGFACLTY
+12 WRITE !
DO LINE
WRITE !
+13 QUIT
+14 ;
LINE ;prints double dash line
+1 NEW LINE
+2 FOR LINE=1:1:80
WRITE "="
+3 QUIT
+4 ;
COLHEAD ;report column header
+1 WRITE "PATIENT NAME",?32,"PID",?39,"REGISTRATION",?53,"LAST EPISODE",?69,"DATE OF"
+2 WRITE !,?39,"DATE",?53,"OF CARE",?69,"DEATH"
+3 WRITE !
DO LINE
WRITE !
+4 QUIT
+5 ;
ASKCONT(FLAG) ; display "press <Enter> to continue" prompt
+1 NEW Z
+2 WRITE !!,$$CJ^XLFSTR("Press <Enter> to "_$SELECT(FLAG=1:"continue.",1:"exit."),20)
+3 READ !,Z:DTIME
+4 QUIT
+5 ;
PAUSE(DGQ) ; pause screen display
+1 ; Input:
+2 ; DGQ - var used to quit report processing to user CRT
+3 ; Output:
+4 ; DGQ - passed by reference - 0 = Continue, 1 = Quit
+5 ;
+6 IF $GET(DGPAGE)>0
IF TRM
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if +Y=0
SET DGQ=1
+7 QUIT
+8 ;
EXIT ;
+1 QUIT
+2 ;
DATEFROM() ;prompt for FROM Date of Service
+1 NEW DGASK,DGDIRA,DGDIRB,DGDIRH,DGDIRO,DGBEGDT,DGSTRTDT
+2 ;03/14/2013 - Presumptive Psychosis legislation date
SET DGBEGDT=3130314
+3 SET DGDIRA=" Start with Date: "
+4 SET DGDIRB=$$FMTE^XLFDT(DGBEGDT)
+5 SET DGDIRH="^D HELP^DGPPRRPT(1)"
+6 SET DGDIRO="DA^"_DGBEGDT_":DT:EX"
+7 SET DGASK=$$ANSWER(DGDIRA,DGDIRB,DGDIRO,DGDIRH)
+8 IF DGASK>0
SET DGSORT("DGBEG")=$SELECT(DGASK<DGBEGDT:DGBEGDT,1:DGASK)
+9 QUIT DGASK>0
+10 ;
DATETO() ;prompt for TO Date of Service
+1 NEW DGASK,DGDIRA,DGDIRB,DGDIRH,DGDIRO,DGDTEND
+2 SET DGDIRA=" End with Date : "
+3 SET DGDIRB="TODAY"
+4 SET DGDIRH="^D HELP^DGPPRRPT(1)"
+5 SET DGDTEND=DGSORT("DGBEG")
+6 SET DGDIRO="DA^"_DGSORT("DGBEG")_":DT:EX"
+7 SET DGASK=$$ANSWER(DGDIRA,DGDIRB,DGDIRO,DGDIRH)
+8 IF DGASK>0
SET DGSORT("DGEND")=DGASK
+9 QUIT DGASK>0
+10 ;
ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH) ;
+1 ; Input
+2 ; DGDIR0 - DIR(0) string
+3 ; DGDIRA - DIR("A") string
+4 ; DGDIRB - DIR("B") string
+5 ; DGDIRH - DIR("?") string
+6 ; Output
+7 ; Function Value - Internal value returned from ^DIR or -1 if user
+8 ; up-arrows, double up-arrows or the read times out.
+9 NEW X,Y,Z,DIR,DIROUT,DIRUT,DTOUT,DUOUT
+10 IF $DATA(DGDIR0)
SET DIR(0)=DGDIR0
+11 IF $DATA(DGDIRA)
MERGE DIR("A")=DGDIRA
+12 IF $GET(DGDIRB)]""
SET DIR("B")=DGDIRB
+13 IF $DATA(DGDIRH)
SET DIR("?")=DGDIRH
SET DIR("??")=DGDIRH
+14 DO ^DIR
KILL DIR
+15 SET Z=$SELECT($DATA(DTOUT):-2,$DATA(DUOUT):-1,$DATA(DIROUT):-1,1:"")
+16 IF Z=""
SET Z=$SELECT(Y=-1:"",X="@":"@",1:$PIECE(Y,U))
QUIT Z
+17 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT -1
+18 QUIT $SELECT(X="@":"@",1:$PIECE(Y,U))
+19 ;
