DGPPRRP1 ;SLC/RM - PRESUMPTIVE PSYCHOSIS RECONCILIATION REPORT CONTINUATION ; Dec 02, 2020@3:00 pm
;;5.3;Registration;**1034,1035**;Aug 13, 1993;Build 14
;
;External References Supported by ICR# Type
;------------------- ----------------- ---------
; $$S^%ZTLOAD 10063 Supported
; ^DIR 10026 Supported
; $$FMTE^XLFDT 10103 Supported
; $$NOW^XLFDT 10103 Supported
; $$CJ^XLFSTR 10104 Supported
Q
;
PRINTPP(DGSORT,DGPPLST) ;output report
N DGPAGE,DDASH,DGQ,DGDFN,DGTOTAL,DGPRINT,DGOLD,DGSTATN,DGPTNAME
S (DGQ,DGTOTAL,DGPAGE,DGPRINT,DGOLD)=0,$P(DDASH,"=",81)=""
I $O(@DGPPLST@(""))="" D Q
. D HEADER,COLHEAD
. W !!!," >>> No records were found using the report criteria.",!!
. W ! D LINE
. D ASKCONT(0)
D HEADER,COLHEAD ; loop and print report
S DGPTNAME="" F S DGPTNAME=$O(@DGPPLST@(DGPTNAME)) Q:DGPTNAME="" D Q:DGQ
. I DGOLD'=DGPTNAME S DGPRINT=0
. S DGDFN="" F S DGDFN=$O(@DGPPLST@(DGPTNAME,DGDFN)) Q:DGDFN="" D Q:DGQ
. . I 'DGPRINT D PRINT1 S DGPRINT=1
. . I $O(@DGPPLST@(DGPTNAME,DGDFN,""))'="" D PRNTOED ;display patient's other eligibilities if there are any AND date of service
. S DGTOTAL=DGTOTAL+1
. S DGOLD=DGPTNAME
. Q:DGQ
W !
Q:DGQ
D LINE
W !!,"Number of Unique Patients: ",$J(DGTOTAL,5)
W !!,"<< end of report >>"
D ASKCONT(0) W @IOF
Q
;
PRINT1 ;print the name, pid, DOB, DOD, PE, Other PE, and PP Category only once
N DGDOD,JJ,DGOTHER
W !
S DGDOD=$P(@DGPPLST@(DGPTNAME,DGDFN),U,4)
W $E(DGPTNAME,1,24) ;patient name
W ?26,$P(@DGPPLST@(DGPTNAME,DGDFN),U,2) ;PID
W ?33,$$FMTE^XLFDT($P(@DGPPLST@(DGPTNAME,DGDFN),U,3),"5Z") ;DOB
W ?45,$S(+DGDOD>0:$$FMTE^XLFDT(DGDOD\1,"5Z"),1:"N/A") ;Date of Death (DOD)
W ?57,$P(@DGPPLST@(DGPTNAME,DGDFN),U,5) ;PP Category
W ?63,$E($P(@DGPPLST@(DGPTNAME,DGDFN),U,6),1,29) ;Primary eligibility
Q
;
PRNTOED ;display patient's other eligibilities if there are any and date of service
N RCNT,DGSTATN,DGPRINT2,DGDOS,CNTR,FILENO,DATEDOS
S CNTR=0
S DGDOS="" F S DGDOS=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS)) Q:DGDOS="" D Q:DGQ
. S RCNT="" F S RCNT=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT)) Q:RCNT="" D Q:DGQ
. . S FILENO="" F S FILENO=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT,"OTHER",FILENO)) Q:FILENO="" D Q:DGQ
. . . S DGSTATN="" F S DGSTATN=$O(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT,"OTHER",FILENO,DGSTATN)) Q:DGSTATN="" D Q:DGQ
. . . . I $Y>(IOSL-4) W ! D PAUSE(.DGQ) Q:DGQ D HEADER,COLHEAD,PRINT1 S CNTR=0
. . . . I CNTR>0 W !
. . . . W ?94,$E($P(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT,"OTHER",FILENO,DGSTATN),U,2),1,26) ;write other eligibility
. . . . S DATEDOS=$P(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT,"OTHER",FILENO,DGSTATN),U)
. . . . I DATEDOS["*" W ?121,$E(DATEDOS,"*",1) S DATEDOS=$P(DATEDOS,"*",2)
. . . . W ?122,$S(+DATEDOS>0:$$FMTE^XLFDT(DATEDOS\1,"5Z"),1:"") ;date of service
. . . . S CNTR=CNTR+1
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 ?(132-$L(ZTDESC))\2,$G(ZTDESC),?120,"Page: ",?127,DGPAGE
W !,?47,"DATE RANGE: ",$$FMTE^XLFDT(DGSORT("DGBEG"),"5Z")," TO ",$$FMTE^XLFDT(DGSORT("DGEND"),"5Z")
W !,?45,"DATE PRINTED: ",$$FMTE^XLFDT($$NOW^XLFDT,"MP")
W !,?48,"FACILITY : "_$P(HERE,U,2)
W !,?47,"'*' = Patient Admission Date"
W ! D LINE W !
Q
;
LINE ;prints double dash line
N LINE
F LINE=1:1:132 W "="
Q
;
COLHEAD ;report column header
W "PATIENT NAME",?26,"PID",?33,"DATE OF",?45,"DATE OF",?57,"PP",?63,"PRIMARY",?94,"OTHER",?122,"DATE OF"
W !,?33,"BIRTH",?45,"DEATH",?57,"CAT",?63,"ELIGIBILITY",?94,"ELIGIBILITIES",?122,"SERVICE"
W !,"------------------------",?26,"-----",?33,"----------",?45,"----------",?57,"----"
W ?63,"-----------------------------",?94,"-------------------------",?122,"----------"
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPPRRP1 4420 printed Dec 13, 2024@02:50:57 Page 2
DGPPRRP1 ;SLC/RM - PRESUMPTIVE PSYCHOSIS RECONCILIATION REPORT CONTINUATION ; Dec 02, 2020@3:00 pm
+1 ;;5.3;Registration;**1034,1035**;Aug 13, 1993;Build 14
+2 ;
+3 ;External References Supported by ICR# Type
+4 ;------------------- ----------------- ---------
+5 ; $$S^%ZTLOAD 10063 Supported
+6 ; ^DIR 10026 Supported
+7 ; $$FMTE^XLFDT 10103 Supported
+8 ; $$NOW^XLFDT 10103 Supported
+9 ; $$CJ^XLFSTR 10104 Supported
+10 QUIT
+11 ;
PRINTPP(DGSORT,DGPPLST) ;output report
+1 NEW DGPAGE,DDASH,DGQ,DGDFN,DGTOTAL,DGPRINT,DGOLD,DGSTATN,DGPTNAME
+2 SET (DGQ,DGTOTAL,DGPAGE,DGPRINT,DGOLD)=0
SET $PIECE(DDASH,"=",81)=""
+3 IF $ORDER(@DGPPLST@(""))=""
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
DO HEADER
DO COLHEAD
+9 SET DGPTNAME=""
FOR
SET DGPTNAME=$ORDER(@DGPPLST@(DGPTNAME))
if DGPTNAME=""
QUIT
Begin DoDot:1
+10 IF DGOLD'=DGPTNAME
SET DGPRINT=0
+11 SET DGDFN=""
FOR
SET DGDFN=$ORDER(@DGPPLST@(DGPTNAME,DGDFN))
if DGDFN=""
QUIT
Begin DoDot:2
+12 IF 'DGPRINT
DO PRINT1
SET DGPRINT=1
+13 ;display patient's other eligibilities if there are any AND date of service
IF $ORDER(@DGPPLST@(DGPTNAME,DGDFN,""))'=""
DO PRNTOED
End DoDot:2
if DGQ
QUIT
+14 SET DGTOTAL=DGTOTAL+1
+15 SET DGOLD=DGPTNAME
+16 if DGQ
QUIT
End DoDot:1
if DGQ
QUIT
+17 WRITE !
+18 if DGQ
QUIT
+19 DO LINE
+20 WRITE !!,"Number of Unique Patients: ",$JUSTIFY(DGTOTAL,5)
+21 WRITE !!,"<< end of report >>"
+22 DO ASKCONT(0)
WRITE @IOF
+23 QUIT
+24 ;
PRINT1 ;print the name, pid, DOB, DOD, PE, Other PE, and PP Category only once
+1 NEW DGDOD,JJ,DGOTHER
+2 WRITE !
+3 SET DGDOD=$PIECE(@DGPPLST@(DGPTNAME,DGDFN),U,4)
+4 ;patient name
WRITE $EXTRACT(DGPTNAME,1,24)
+5 ;PID
WRITE ?26,$PIECE(@DGPPLST@(DGPTNAME,DGDFN),U,2)
+6 ;DOB
WRITE ?33,$$FMTE^XLFDT($PIECE(@DGPPLST@(DGPTNAME,DGDFN),U,3),"5Z")
+7 ;Date of Death (DOD)
WRITE ?45,$SELECT(+DGDOD>0:$$FMTE^XLFDT(DGDOD\1,"5Z"),1:"N/A")
+8 ;PP Category
WRITE ?57,$PIECE(@DGPPLST@(DGPTNAME,DGDFN),U,5)
+9 ;Primary eligibility
WRITE ?63,$EXTRACT($PIECE(@DGPPLST@(DGPTNAME,DGDFN),U,6),1,29)
+10 QUIT
+11 ;
PRNTOED ;display patient's other eligibilities if there are any and date of service
+1 NEW RCNT,DGSTATN,DGPRINT2,DGDOS,CNTR,FILENO,DATEDOS
+2 SET CNTR=0
+3 SET DGDOS=""
FOR
SET DGDOS=$ORDER(@DGPPLST@(DGPTNAME,DGDFN,DGDOS))
if DGDOS=""
QUIT
Begin DoDot:1
+4 SET RCNT=""
FOR
SET RCNT=$ORDER(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT))
if RCNT=""
QUIT
Begin DoDot:2
+5 SET FILENO=""
FOR
SET FILENO=$ORDER(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT,"OTHER",FILENO))
if FILENO=""
QUIT
Begin DoDot:3
+6 SET DGSTATN=""
FOR
SET DGSTATN=$ORDER(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT,"OTHER",FILENO,DGSTATN))
if DGSTATN=""
QUIT
Begin DoDot:4
+7 IF $Y>(IOSL-4)
WRITE !
DO PAUSE(.DGQ)
if DGQ
QUIT
DO HEADER
DO COLHEAD
DO PRINT1
SET CNTR=0
+8 IF CNTR>0
WRITE !
+9 ;write other eligibility
WRITE ?94,$EXTRACT($PIECE(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT,"OTHER",FILENO,DGSTATN),U,2),1,26)
+10 SET DATEDOS=$PIECE(@DGPPLST@(DGPTNAME,DGDFN,DGDOS,RCNT,"OTHER",FILENO,DGSTATN),U)
+11 IF DATEDOS["*"
WRITE ?121,$EXTRACT(DATEDOS,"*",1)
SET DATEDOS=$PIECE(DATEDOS,"*",2)
+12 ;date of service
WRITE ?122,$SELECT(+DATEDOS>0:$$FMTE^XLFDT(DATEDOS\1,"5Z"),1:"")
+13 SET CNTR=CNTR+1
End DoDot:4
if DGQ
QUIT
End DoDot:3
if DGQ
QUIT
End DoDot:2
if DGQ
QUIT
End DoDot:1
if DGQ
QUIT
+14 QUIT
+15 ;
+1 NEW DGFACLTY,DGDTRNGE,DTPRNTD
+2 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,DGQ)=1
QUIT
+3 IF TRM!('TRM&DGPAGE)
WRITE @IOF
+4 SET DGPAGE=$GET(DGPAGE)+1
+5 WRITE ?(132-$LENGTH(ZTDESC))\2,$GET(ZTDESC),?120,"Page: ",?127,DGPAGE
+6 WRITE !,?47,"DATE RANGE: ",$$FMTE^XLFDT(DGSORT("DGBEG"),"5Z")," TO ",$$FMTE^XLFDT(DGSORT("DGEND"),"5Z")
+7 WRITE !,?45,"DATE PRINTED: ",$$FMTE^XLFDT($$NOW^XLFDT,"MP")
+8 WRITE !,?48,"FACILITY : "_$PIECE(HERE,U,2)
+9 WRITE !,?47,"'*' = Patient Admission Date"
+10 WRITE !
DO LINE
WRITE !
+11 QUIT
+12 ;
LINE ;prints double dash line
+1 NEW LINE
+2 FOR LINE=1:1:132
WRITE "="
+3 QUIT
+4 ;
COLHEAD ;report column header
+1 WRITE "PATIENT NAME",?26,"PID",?33,"DATE OF",?45,"DATE OF",?57,"PP",?63,"PRIMARY",?94,"OTHER",?122,"DATE OF"
+2 WRITE !,?33,"BIRTH",?45,"DEATH",?57,"CAT",?63,"ELIGIBILITY",?94,"ELIGIBILITIES",?122,"SERVICE"
+3 WRITE !,"------------------------",?26,"-----",?33,"----------",?45,"----------",?57,"----"
+4 WRITE ?63,"-----------------------------",?94,"-------------------------",?122,"----------"
+5 QUIT
+6 ;
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 IF $GET(DGPAGE)>0
IF TRM
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if +Y=0
SET DGQ=1
+6 QUIT
+7 ;
