- 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 Feb 19, 2025@00:16:59 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 ;