DGOTHRP2 ;SLC/RM - OTH PATIENT PERIOD STATUS REPORT CONT. ;MAY 8, 2018@5:15
;;5.3;Registration;**952,977**;Aug 13, 1993;Build 177
;;Per VA Directive 6402, this routine should not be modified
;
; Last Edited: SHRPE/RM - MAY 8, 2018 17:15
;
; ICR# TYPE DESCRIPTION
;----- ---- -------------------------------
; 10103 Sup ^XLFDT - [$$FMTE^XLFDT, $$NOW^XLFDT]
; 10015 Sup ^DIQ
; 10086 Sup HOME^%ZIS
; 10063 Sup ^%ZTLOAD
; 1519 Sup EN^XUTMDEVQ
; 10089 Sup ^%ZISC
; 10026 Sup ^DIR
; 10112 Sup $$SITE^VASITE
; 10024 Sup WAIT^DICD
; 664 Cont. Sub DIVISION^VAUTOMA
; 417 Cont. Sub DG has approval for direct global read of File #40.8
; 3546 Cont. Sub DG has approval for direct global read of "AD" index of FILE #40.8
; 402 Cont. Sub DG has approval for direct global read of "ADFN" index of FILE #409.68 ;
;This routine will be used to display or print Other Than Honorable
;Active 90-Day Period Status
;Expired 90-Day Period Status
;Both (Active and Expired) 90-Day Period Status
;
; INPUT: DGSORT() - see comments at the top of routine DGOTHRPT for
; explanation of DGSORT array
;
; Output: A formatted report of Other Than Honorable
; Active 90-Day Period Status
;
;- no direct entry
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
N TRM S TRM=($E(IOST)="C")
N DGLIST ;temp global name used for report list
S DGLIST=$NA(^TMP("DGOTHR2",$J))
K @DGLIST
D LOOP(.DGSORT,DGLIST)
D PRINT(.DGSORT,DGLIST)
K @DGLIST
D EXIT
Q
;
LOOP(DGSORT,DGLIST) ;
N DGDFN,DGDIEN,DGQ,DGRES,DGIEN,DGOLD,DGTOTAL,DGARR,DGRET,DGCLCK,DG90A,DGERR,RET
;loop variable pointer flag x-ref file to run report
S (DGDFN,DGIEN,DGOLD)="",(DGTOTAL,DGQ)=0
F S DGDFN=$O(^DGOTH(33,"B",DGDFN)) Q:DGDFN="" D
. N DGIEN33,DFN,DGPTSTAT,DGLS365D,DGLS365I
. K DGARR,DGRET,DGCLCK,DG90A,DGERR,RET
. ;Patient's primary eligibility code is no longer EXPANDED MH CARE NON-ENROLLEE
. Q:$$ISOTHD^DGOTHD(DGDFN)=0
. ;Patient's current MH CARE TYPE is no longer OTH-90
. Q:'$$ISOTH90(DGDFN)
. S DGIEN33=+$O(^DGOTH(33,"B",DGDFN,0))
. D GETS^DIQ(33,DGIEN33_",",".01;.02;1*;2*","IE","DGARR","DGERR")
. Q:$D(DGERR)
. I DGARR(33,DGIEN33_",",.02,"I")<1 Q
. D CLOCK(DGIEN33)
. Q:'$D(DGCLCK)
. I $$MSNGPRD^DGOTHBTN(DGLS365D,.DGCLCK) Q
. D RESULT^DGOTHRP3(.DGARR,.DG90A,DGIEN33)
. Q:'$D(DGRET)
. S DFN=$G(DGARR(33,DGIEN33_",",.01,"I"))
. I $D(DGSORT("DGSTATUS")) D ALL90(.DGSORT,DGLIST,.DGRET,DFN,DGIEN33,.DGARR,.DG90A)
Q
;
ISOTH90(DGDFN) ;determine if patient is EMERGENT OTH
N DGEXP
S DGEXP=$$GETEXPR^DGOTHD(DGDFN)
I DGEXP="" Q 0
I DGEXP<0 Q 0
I DGEXP'?1"OTH".E Q 0
I $$ISOTH^DGOTHD(DGEXP)>1 Q 1
Q 0
;
CLOCK(DGIEN33) ;
N DGN
S DGLS365D=+$O(^DGOTH(33,DGIEN33,1,"B",999),-1)
S DGLS365I=+$O(^DGOTH(33,DGIEN33,1,"B",DGLS365D,0))
F I=1:1:DGLS365D D
. S DGN=0 F S DGN=+$O(^DGOTH(33,DGIEN33,1,I,1,"B",DGN)) Q:DGN=0 D
. . S DG90A(DGN)=+$O(^DGOTH(33,DGIEN33,1,I,1,"B",DGN,0))
. . S DGCLCK(I)=$G(DGCLCK(I))+1,DGCLCK(I,$G(DGCLCK(I)))=DGN ;+$O(^DGOTH(33,DGIEN33,1,I,1,"B",DGN,0))
Q
;
ALL90(DGSORT,DGLIST,DGRET,DFN,DGIEN33,DGARR,DG90A) ;
N DGPTNM,DGSSN,DGAUTH,DGIENS,I,II,DGTMP,DG90,DGSDT,DGEDT,DGDYSLFT,DGENCTR
F I=1:1:DGLS365D D
. S DG90="" F S DG90=$O(DGRET(I,DG90)) Q:DG90="" D
. . K DGPTNM,DGSSN,DGAUTH,DGIENS,DGSDT,DGEDT,DGDYSLFT
. . S DGSDT=$P(DGRET(I,DG90),U)
. . S DGEDT=$P(DGRET(I,DG90),U,2)
. . S DGDYSLFT=$P(DGRET(I,DG90),U,3)
. . I 1[$P(DGSORT("DGSTATUS"),U),DGDYSLFT<1 Q
. . ;if user select EXPIRED 90-DAY PERIOD,check if the entire
. . ;365-day period of that patient is expired,if true,include them in the report
. . ;otherwise, skip those patients
. . I 2[$P(DGSORT("DGSTATUS"),U),DGRET(I)>0 Q
. . I 2[$P(DGSORT("DGSTATUS"),U),DGRET(I)<1,$D(DGRET(I+1)) Q
. . I $$CHKDATE(DGSDT,DGEDT) D
. . . K DGENCTR
. . . ;check if there any Outpatient Encounter entry for this patient
. . . D CHKTREAT^DGPPRP1(.DGENCTR,+DFN,DGSORT("DGBEG"),DGSORT("DGEND"),.VAUTD) Q:'$D(DGENCTR)
. . . S DGPTNM=DGARR(33,DGIEN33_",",.01,"E")
. . . S DGSSN=$$SSN(DFN)
. . . S DGIENS=DGCLCK(I,DG90)_","_I_","_+DGIEN33_","
. . . S DGAUTH=$S($G(DGARR(33.11,DGIENS,.07,"E"))="":"N/A",1:$G(DGARR(33.11,DGIENS,.07,"E")))
. . . S DGTMP=DG90_U_DGSSN_U_$$FMTE^XLFDT(DGSDT,"5Z")_U_$$FMTE^XLFDT(DGEDT,"5Z")_U_DGDYSLFT_U_DGAUTH_U_I
. . . D SORT(DGTMP,DGPTNM,DG90,DGDYSLFT,I,.DGENCTR)
Q
;
SSN(DFN) ;extract patient's SSN4
D GETS^DIQ(2,DFN_",",.0905,"ER","DGSSN")
Q DGSSN(2,DFN_",","1U4N","E")
;
SORT(DGTMP,DGPTNM,DGCLCK,DGDYSLFT,I,DGENCTR) ;
N DGDIV,DGSDT,DGDIVNUM
S (DGDIV,DGSDT)=""
F S DGDIV=$O(DGENCTR(DGDIV)) Q:DGDIV="" D
. F S DGSDT=$O(DGENCTR(DGDIV,DGSDT)) Q:DGSDT="" D
. . K DGDIVNUM
. . S DGDIVNUM=$P(DGENCTR(DGDIV,DGSDT),U,2)
. . I DGDIVNUM="" S DGDIVNUM=$S($P(^DG(40.8,DGDIV,0),U,2)="":"UNKNOWN",1:$P(^DG(40.8,DGDIV,0),U,2))
. . I DGDIVNUM["UNKNOWN" S DGSORT("DIVISION",DGDIV,DGDIVNUM)=$P(DGENCTR(DGDIV,DGSDT),U)
. . ;1 = Sort by Patient Name
. . I '$D(@DGLIST@(DGDIV)) S @DGLIST@(DGDIVNUM)=$P(DGENCTR(DGDIV,DGSDT),U)
. . I $P(DGSORT("DGSRTBY"),U)=1 D
. . . I 1[$P(DGSORT("REPORT"),U) S @DGLIST@(DGDIVNUM,DGPTNM,I,DGCLCK)=DGTMP Q
. . . S @DGLIST@(DGPTNM,I,DGCLCK)=DGTMP
. . ;2 = Sort by Period
. . I $P(DGSORT("DGSRTBY"),U)=2 D
. . . I 1[$P(DGSORT("REPORT"),U) S @DGLIST@(DGDIVNUM,DGCLCK,I,DGPTNM)=DGTMP Q
. . . S @DGLIST@(DGCLCK,I,DGPTNM)=DGTMP
. . ;3 = Sort by Days Remaining
. . I $P(DGSORT("DGSRTBY"),U)=3 D
. . . I 1[$P(DGSORT("REPORT"),U) S @DGLIST@(DGDIVNUM,DGDYSLFT,I,DGPTNM,DGCLCK)=DGTMP Q
. . . S @DGLIST@(DGDYSLFT,I,DGPTNM,DGCLCK)=DGTMP
;
I DGOLD'=DGPTNM S DGTOTAL=DGTOTAL+1,DGOLD=DGPTNM
I DGTOTAL>0 S @DGLIST@("DGTOTAL")=DGTOTAL
Q
;
CHKDATE(DGSDT,DGEDT) ;check if dates fall within the Begin and End dates
Q DGSORT("DGBEG")<=DGEDT&(DGSORT("DGEND")>=DGEDT)
;
PRINT(DGSORT,DGLIST) ;output report
N DGPAGE,DDASH,DGQ,DGSUB1,DGSUB2,DGSUB3,DGSUB4,DGSUB5
N DGSTR,DGOLD,DGOLD365,DGTOTAL,DGDIV,DGFAC,DGOEIEN,DGNEWDIV
S (DGQ,DGTOTAL,DGPAGE)=0,$P(DDASH,"-",81)=""
S DGTOTAL=$G(@DGLIST@("DGTOTAL"))
I $O(@DGLIST@(""))="" D Q
. D HEAD
. W !!," >>> No OTH-90 records were found using the report criteria.",!
. D ASKCONT^DGOTHMG2
; loop and print report
S (DGSUB1,DGSUB2,DGSUB3,DGSUB4,DGSUB5,DGSTR,DGOLD,DGOLD365,DGDIV)=""
I 1[$P(DGSORT("REPORT"),U) D
.S DGOEIEN="" F S DGOEIEN=$O(DGSORT("DIVISION",DGOEIEN)) Q:DGOEIEN="" D Q:DGQ
..S DGFAC="" F S DGFAC=$O(DGSORT("DIVISION",DGOEIEN,DGFAC)) Q:DGFAC="" D Q:DGQ
...D HEAD,DVISION(DGFAC) S DGNEWDIV=1
...I '$D(@DGLIST@(DGFAC)) D Q
....W !," >>> No records were found for this Division.",!!
....W ! D PAUSE^DGOTHRP2(.DGQ)
....Q
...D PRINT1(DGFAC)
...S DGDIV=DGFAC
...Q
..Q
.Q
I 2[$P(DGSORT("REPORT"),U) D
. D HEAD
. S DGSUB1="" F S DGSUB1=$O(@DGLIST@(DGSUB1)) Q:DGSUB1="" D Q:DGQ
. . D PRINT1(DGSUB1)
. Q:DGQ
. W ! D PAUSE^DGOTHRP2(.DGQ) Q:DGQ W !
Q:DGQ
D HEAD D RPTSUM
Q
;
;DG*5.3*977 OTH-EXT
PRINT1(DGSUB1) ;Print or display report by division
F S DGSUB2=$O(@DGLIST@(DGSUB1,DGSUB2)) Q:DGSUB2="" D Q:DGQ
.F S DGSUB3=$O(@DGLIST@(DGSUB1,DGSUB2,DGSUB3)) Q:DGSUB3="" D Q:DGQ
..I 2[$P(DGSORT("REPORT"),U) Q:DGQ D PRNTFC Q
..F S DGSUB4=$O(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4)) Q:DGSUB4="" D Q:DGQ
...K DGSTR
...I $P(DGSORT("DGSRTBY"),U)=3,1[$P(DGSORT("REPORT"),U) Q:DGQ D Q
....F S DGSUB5=$O(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4,DGSUB5)) Q:DGSUB5="" D Q:DGQ
.....S DGSTR=$G(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4,DGSUB5)) D PRINT2
.....Q
....Q
...I $G(DGSTR)="" S DGSTR=$G(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4))
...D PRINT2 S DGNEWDIV=0
..Q
.Q
Q:DGQ
I DGDIV'=DGSUB1,1[$P(DGSORT("REPORT"),U) W ! D PAUSE^DGOTHRP2(.DGQ) Q:DGQ W !
Q
;
PRINT2 ;
W !
I $Y>(IOSL-4) D PAUSE(.DGQ) Q:DGQ D HEAD W ! D DVISION(DGSUB1) W ! I DGOLD=DGSUB2 D PTNAME
I $P(DGSORT("DGSRTBY"),U)=1,DGNEWDIV!(DGSUB2'=DGOLD) D PTNAME S DGOLD=DGSUB2,DGOLD365=""
I $P(DGSORT("DGSRTBY"),U)=2!($P(DGSORT("DGSRTBY"),U)=3),DGNEWDIV!(DGSUB4'=DGOLD) W $E(DGSUB4,1,18),?20,$P(DGSTR,U,2) S DGOLD=DGSUB4,DGOLD365=""
I DGNEWDIV!(DGSUB3'=DGOLD365) W ?27,DGSUB3 S DGOLD365=DGSUB3
W ?31,$P(DGSTR,U),?35,$P(DGSTR,U,3),?47,$P(DGSTR,U,4),?59,$P(DGSTR,U,5),?65,$E($P(DGSTR,U,6),1,15)
Q
;
PTNAME ;diplay patient and PID
W $E(DGSUB2,1,18),?20,$P(DGSTR,U,2)
Q
;
;DG*5.3*977 OTH-EXT
PRNTFC ;Print or display report by facility
K DGSTR
I $P(DGSORT("DGSRTBY"),U)=3 Q:DGQ D Q
. F S DGSUB4=$O(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4)) Q:DGSUB4="" D Q:DGQ
. . S DGSTR=$G(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4))
. . D PRNTFC1
I $G(DGSTR)="" S DGSTR=$G(@DGLIST@(DGSUB1,DGSUB2,DGSUB3))
D PRNTFC1
Q
;
PRNTFC1 ;
W !
I $Y>(IOSL-4) D PAUSE(.DGQ) Q:DGQ D HEAD W !
I $P(DGSORT("DGSRTBY"),U)=1,DGSUB1'=DGOLD W $E(DGSUB1,1,18),?20,$P(DGSTR,U,2) S DGOLD=DGSUB1,DGOLD365=""
I $P(DGSORT("DGSRTBY"),U)=2!($P(DGSORT("DGSRTBY"),U)=3),DGSUB3'=DGOLD W $E(DGSUB3,1,18),?20,$P(DGSTR,U,2) S DGOLD=DGSUB3,DGOLD365=""
I DGSUB2'=DGOLD365 W ?27,DGSUB2 S DGOLD365=DGSUB2
W ?31,$P(DGSTR,U),?35,$P(DGSTR,U,3),?47,$P(DGSTR,U,4),?59,$P(DGSTR,U,5),?65,$E($P(DGSTR,U,6),1,15)
Q:DGQ
Q
;
RPTSUM ;Display report summary
W !!,"REPORT SUMMARY:"
W !,"==============="
W !!,"Total "_$S(1[$P(DGSORT("DGSTATUS"),U):"Active",2[$P(DGSORT("DGSTATUS"),U):"Expired",1:"Active/Expired")
W " OTH 90-DAY PERIOD from ",$$FMTE^XLFDT($G(DGSORT("DGBEG")),"5Z")
W " to ",$$FMTE^XLFDT($G(DGSORT("DGEND")),"5Z"),":",$J($S(DGTOTAL>0:DGTOTAL,1:0),4),!
W !,"<END OF REPORT>"
D ASKCONT^DGOTHMG2
Q
;
;DG*5.3*977 OTH-EXT
DVISION(DGFAC) ;
W "Division: ",DGSORT("DIVISION",DGOEIEN,DGFAC)_" ("_DGFAC_")",!
Q
;
HEAD ;Print/Display Page Header
I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQ)=1 Q
N DGFACLTY
I TRM!('TRM&DGPAGE) W @IOF
S DGPAGE=$G(DGPAGE)+1
S DGFACLTY="Facility: "_$P(HERE,U,2)
W !,?80-$L(ZTDESC)\2,$G(ZTDESC),?71,"Page:",?77,DGPAGE
W !,?80-$L(DGFACLTY)\2,DGFACLTY
W !,"Date Range:",?12,$$FMTE^XLFDT(DGSORT("DGBEG"),"5Z")_" TO "_$$FMTE^XLFDT(DGSORT("DGEND"),"5Z")
W ?45,"Sorted By:",?56,$S(2[$P(DGSORT("REPORT"),U):"",1:$P(DGSORT("REPORT"),U,2)_","),$P($G(DGSORT("DGSRTBY")),U,2)
W !,"Status :",?12,$P($G(DGSORT("DGSTATUS")),U,2)
W ?45,"Printed :",?56,$$FMTE^XLFDT($$NOW^XLFDT,"MP")
W !,DDASH
W !,"PATIENT NAME",?20,"PID",?26,"365",?31,"90",?35,"START DATE",?47,"END DATE",?59,"DAYS",?65,"AUTHORIZED BY"
W !,?26,"PRD",?31,"PRD",?59,"LEFT"
W !,DDASH
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 ;
I $D(ZTQUEUED) S ZTREQ="@" ;tell TaskMan to delete Task log entry
I '$D(ZTQUEUED) D
. I 'TRM,$Y>0 W @IOF
. K %ZIS,POP
. D ^%ZISC,HOME^%ZIS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGOTHRP2 11152 printed Sep 23, 2025@20:22:51 Page 2
DGOTHRP2 ;SLC/RM - OTH PATIENT PERIOD STATUS REPORT CONT. ;MAY 8, 2018@5:15
+1 ;;5.3;Registration;**952,977**;Aug 13, 1993;Build 177
+2 ;;Per VA Directive 6402, this routine should not be modified
+3 ;
+4 ; Last Edited: SHRPE/RM - MAY 8, 2018 17:15
+5 ;
+6 ; ICR# TYPE DESCRIPTION
+7 ;----- ---- -------------------------------
+8 ; 10103 Sup ^XLFDT - [$$FMTE^XLFDT, $$NOW^XLFDT]
+9 ; 10015 Sup ^DIQ
+10 ; 10086 Sup HOME^%ZIS
+11 ; 10063 Sup ^%ZTLOAD
+12 ; 1519 Sup EN^XUTMDEVQ
+13 ; 10089 Sup ^%ZISC
+14 ; 10026 Sup ^DIR
+15 ; 10112 Sup $$SITE^VASITE
+16 ; 10024 Sup WAIT^DICD
+17 ; 664 Cont. Sub DIVISION^VAUTOMA
+18 ; 417 Cont. Sub DG has approval for direct global read of File #40.8
+19 ; 3546 Cont. Sub DG has approval for direct global read of "AD" index of FILE #40.8
+20 ; 402 Cont. Sub DG has approval for direct global read of "ADFN" index of FILE #409.68 ;
+21 ;This routine will be used to display or print Other Than Honorable
+22 ;Active 90-Day Period Status
+23 ;Expired 90-Day Period Status
+24 ;Both (Active and Expired) 90-Day Period Status
+25 ;
+26 ; INPUT: DGSORT() - see comments at the top of routine DGOTHRPT for
+27 ; explanation of DGSORT array
+28 ;
+29 ; Output: A formatted report of Other Than Honorable
+30 ; Active 90-Day Period Status
+31 ;
+32 ;- no direct entry
+33 QUIT
+34 ;
START ; compile and print report
+1 IF $EXTRACT(IOST)="C"
DO WAIT^DICD
+2 ;extract the IEN and facility name
NEW HERE
SET HERE=$$SITE^VASITE
+3 NEW TRM
SET TRM=($EXTRACT(IOST)="C")
+4 ;temp global name used for report list
NEW DGLIST
+5 SET DGLIST=$NAME(^TMP("DGOTHR2",$JOB))
+6 KILL @DGLIST
+7 DO LOOP(.DGSORT,DGLIST)
+8 DO PRINT(.DGSORT,DGLIST)
+9 KILL @DGLIST
+10 DO EXIT
+11 QUIT
+12 ;
LOOP(DGSORT,DGLIST) ;
+1 NEW DGDFN,DGDIEN,DGQ,DGRES,DGIEN,DGOLD,DGTOTAL,DGARR,DGRET,DGCLCK,DG90A,DGERR,RET
+2 ;loop variable pointer flag x-ref file to run report
+3 SET (DGDFN,DGIEN,DGOLD)=""
SET (DGTOTAL,DGQ)=0
+4 FOR
SET DGDFN=$ORDER(^DGOTH(33,"B",DGDFN))
if DGDFN=""
QUIT
Begin DoDot:1
+5 NEW DGIEN33,DFN,DGPTSTAT,DGLS365D,DGLS365I
+6 KILL DGARR,DGRET,DGCLCK,DG90A,DGERR,RET
+7 ;Patient's primary eligibility code is no longer EXPANDED MH CARE NON-ENROLLEE
+8 if $$ISOTHD^DGOTHD(DGDFN)=0
QUIT
+9 ;Patient's current MH CARE TYPE is no longer OTH-90
+10 if '$$ISOTH90(DGDFN)
QUIT
+11 SET DGIEN33=+$ORDER(^DGOTH(33,"B",DGDFN,0))
+12 DO GETS^DIQ(33,DGIEN33_",",".01;.02;1*;2*","IE","DGARR","DGERR")
+13 if $DATA(DGERR)
QUIT
+14 IF DGARR(33,DGIEN33_",",.02,"I")<1
QUIT
+15 DO CLOCK(DGIEN33)
+16 if '$DATA(DGCLCK)
QUIT
+17 IF $$MSNGPRD^DGOTHBTN(DGLS365D,.DGCLCK)
QUIT
+18 DO RESULT^DGOTHRP3(.DGARR,.DG90A,DGIEN33)
+19 if '$DATA(DGRET)
QUIT
+20 SET DFN=$GET(DGARR(33,DGIEN33_",",.01,"I"))
+21 IF $DATA(DGSORT("DGSTATUS"))
DO ALL90(.DGSORT,DGLIST,.DGRET,DFN,DGIEN33,.DGARR,.DG90A)
End DoDot:1
+22 QUIT
+23 ;
ISOTH90(DGDFN) ;determine if patient is EMERGENT OTH
+1 NEW DGEXP
+2 SET DGEXP=$$GETEXPR^DGOTHD(DGDFN)
+3 IF DGEXP=""
QUIT 0
+4 IF DGEXP<0
QUIT 0
+5 IF DGEXP'?1"OTH".E
QUIT 0
+6 IF $$ISOTH^DGOTHD(DGEXP)>1
QUIT 1
+7 QUIT 0
+8 ;
CLOCK(DGIEN33) ;
+1 NEW DGN
+2 SET DGLS365D=+$ORDER(^DGOTH(33,DGIEN33,1,"B",999),-1)
+3 SET DGLS365I=+$ORDER(^DGOTH(33,DGIEN33,1,"B",DGLS365D,0))
+4 FOR I=1:1:DGLS365D
Begin DoDot:1
+5 SET DGN=0
FOR
SET DGN=+$ORDER(^DGOTH(33,DGIEN33,1,I,1,"B",DGN))
if DGN=0
QUIT
Begin DoDot:2
+6 SET DG90A(DGN)=+$ORDER(^DGOTH(33,DGIEN33,1,I,1,"B",DGN,0))
+7 ;+$O(^DGOTH(33,DGIEN33,1,I,1,"B",DGN,0))
SET DGCLCK(I)=$GET(DGCLCK(I))+1
SET DGCLCK(I,$GET(DGCLCK(I)))=DGN
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
ALL90(DGSORT,DGLIST,DGRET,DFN,DGIEN33,DGARR,DG90A) ;
+1 NEW DGPTNM,DGSSN,DGAUTH,DGIENS,I,II,DGTMP,DG90,DGSDT,DGEDT,DGDYSLFT,DGENCTR
+2 FOR I=1:1:DGLS365D
Begin DoDot:1
+3 SET DG90=""
FOR
SET DG90=$ORDER(DGRET(I,DG90))
if DG90=""
QUIT
Begin DoDot:2
+4 KILL DGPTNM,DGSSN,DGAUTH,DGIENS,DGSDT,DGEDT,DGDYSLFT
+5 SET DGSDT=$PIECE(DGRET(I,DG90),U)
+6 SET DGEDT=$PIECE(DGRET(I,DG90),U,2)
+7 SET DGDYSLFT=$PIECE(DGRET(I,DG90),U,3)
+8 IF 1[$PIECE(DGSORT("DGSTATUS"),U)
IF DGDYSLFT<1
QUIT
+9 ;if user select EXPIRED 90-DAY PERIOD,check if the entire
+10 ;365-day period of that patient is expired,if true,include them in the report
+11 ;otherwise, skip those patients
+12 IF 2[$PIECE(DGSORT("DGSTATUS"),U)
IF DGRET(I)>0
QUIT
+13 IF 2[$PIECE(DGSORT("DGSTATUS"),U)
IF DGRET(I)<1
IF $DATA(DGRET(I+1))
QUIT
+14 IF $$CHKDATE(DGSDT,DGEDT)
Begin DoDot:3
+15 KILL DGENCTR
+16 ;check if there any Outpatient Encounter entry for this patient
+17 DO CHKTREAT^DGPPRP1(.DGENCTR,+DFN,DGSORT("DGBEG"),DGSORT("DGEND"),.VAUTD)
if '$DATA(DGENCTR)
QUIT
+18 SET DGPTNM=DGARR(33,DGIEN33_",",.01,"E")
+19 SET DGSSN=$$SSN(DFN)
+20 SET DGIENS=DGCLCK(I,DG90)_","_I_","_+DGIEN33_","
+21 SET DGAUTH=$SELECT($GET(DGARR(33.11,DGIENS,.07,"E"))="":"N/A",1:$GET(DGARR(33.11,DGIENS,.07,"E")))
+22 SET DGTMP=DG90_U_DGSSN_U_$$FMTE^XLFDT(DGSDT,"5Z")_U_$$FMTE^XLFDT(DGEDT,"5Z")_U_DGDYSLFT_U_DGAUTH_U_I
+23 DO SORT(DGTMP,DGPTNM,DG90,DGDYSLFT,I,.DGENCTR)
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
SSN(DFN) ;extract patient's SSN4
+1 DO GETS^DIQ(2,DFN_",",.0905,"ER","DGSSN")
+2 QUIT DGSSN(2,DFN_",","1U4N","E")
+3 ;
SORT(DGTMP,DGPTNM,DGCLCK,DGDYSLFT,I,DGENCTR) ;
+1 NEW DGDIV,DGSDT,DGDIVNUM
+2 SET (DGDIV,DGSDT)=""
+3 FOR
SET DGDIV=$ORDER(DGENCTR(DGDIV))
if DGDIV=""
QUIT
Begin DoDot:1
+4 FOR
SET DGSDT=$ORDER(DGENCTR(DGDIV,DGSDT))
if DGSDT=""
QUIT
Begin DoDot:2
+5 KILL DGDIVNUM
+6 SET DGDIVNUM=$PIECE(DGENCTR(DGDIV,DGSDT),U,2)
+7 IF DGDIVNUM=""
SET DGDIVNUM=$SELECT($PIECE(^DG(40.8,DGDIV,0),U,2)="":"UNKNOWN",1:$PIECE(^DG(40.8,DGDIV,0),U,2))
+8 IF DGDIVNUM["UNKNOWN"
SET DGSORT("DIVISION",DGDIV,DGDIVNUM)=$PIECE(DGENCTR(DGDIV,DGSDT),U)
+9 ;1 = Sort by Patient Name
+10 IF '$DATA(@DGLIST@(DGDIV))
SET @DGLIST@(DGDIVNUM)=$PIECE(DGENCTR(DGDIV,DGSDT),U)
+11 IF $PIECE(DGSORT("DGSRTBY"),U)=1
Begin DoDot:3
+12 IF 1[$PIECE(DGSORT("REPORT"),U)
SET @DGLIST@(DGDIVNUM,DGPTNM,I,DGCLCK)=DGTMP
QUIT
+13 SET @DGLIST@(DGPTNM,I,DGCLCK)=DGTMP
End DoDot:3
+14 ;2 = Sort by Period
+15 IF $PIECE(DGSORT("DGSRTBY"),U)=2
Begin DoDot:3
+16 IF 1[$PIECE(DGSORT("REPORT"),U)
SET @DGLIST@(DGDIVNUM,DGCLCK,I,DGPTNM)=DGTMP
QUIT
+17 SET @DGLIST@(DGCLCK,I,DGPTNM)=DGTMP
End DoDot:3
+18 ;3 = Sort by Days Remaining
+19 IF $PIECE(DGSORT("DGSRTBY"),U)=3
Begin DoDot:3
+20 IF 1[$PIECE(DGSORT("REPORT"),U)
SET @DGLIST@(DGDIVNUM,DGDYSLFT,I,DGPTNM,DGCLCK)=DGTMP
QUIT
+21 SET @DGLIST@(DGDYSLFT,I,DGPTNM,DGCLCK)=DGTMP
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
+23 IF DGOLD'=DGPTNM
SET DGTOTAL=DGTOTAL+1
SET DGOLD=DGPTNM
+24 IF DGTOTAL>0
SET @DGLIST@("DGTOTAL")=DGTOTAL
+25 QUIT
+26 ;
CHKDATE(DGSDT,DGEDT) ;check if dates fall within the Begin and End dates
+1 QUIT DGSORT("DGBEG")<=DGEDT&(DGSORT("DGEND")>=DGEDT)
+2 ;
PRINT(DGSORT,DGLIST) ;output report
+1 NEW DGPAGE,DDASH,DGQ,DGSUB1,DGSUB2,DGSUB3,DGSUB4,DGSUB5
+2 NEW DGSTR,DGOLD,DGOLD365,DGTOTAL,DGDIV,DGFAC,DGOEIEN,DGNEWDIV
+3 SET (DGQ,DGTOTAL,DGPAGE)=0
SET $PIECE(DDASH,"-",81)=""
+4 SET DGTOTAL=$GET(@DGLIST@("DGTOTAL"))
+5 IF $ORDER(@DGLIST@(""))=""
Begin DoDot:1
+6 DO HEAD
+7 WRITE !!," >>> No OTH-90 records were found using the report criteria.",!
+8 DO ASKCONT^DGOTHMG2
End DoDot:1
QUIT
+9 ; loop and print report
+10 SET (DGSUB1,DGSUB2,DGSUB3,DGSUB4,DGSUB5,DGSTR,DGOLD,DGOLD365,DGDIV)=""
+11 IF 1[$PIECE(DGSORT("REPORT"),U)
Begin DoDot:1
+12 SET DGOEIEN=""
FOR
SET DGOEIEN=$ORDER(DGSORT("DIVISION",DGOEIEN))
if DGOEIEN=""
QUIT
Begin DoDot:2
+13 SET DGFAC=""
FOR
SET DGFAC=$ORDER(DGSORT("DIVISION",DGOEIEN,DGFAC))
if DGFAC=""
QUIT
Begin DoDot:3
+14 DO HEAD
DO DVISION(DGFAC)
SET DGNEWDIV=1
+15 IF '$DATA(@DGLIST@(DGFAC))
Begin DoDot:4
+16 WRITE !," >>> No records were found for this Division.",!!
+17 WRITE !
DO PAUSE^DGOTHRP2(.DGQ)
+18 QUIT
End DoDot:4
QUIT
+19 DO PRINT1(DGFAC)
+20 SET DGDIV=DGFAC
+21 QUIT
End DoDot:3
if DGQ
QUIT
+22 QUIT
End DoDot:2
if DGQ
QUIT
+23 QUIT
End DoDot:1
+24 IF 2[$PIECE(DGSORT("REPORT"),U)
Begin DoDot:1
+25 DO HEAD
+26 SET DGSUB1=""
FOR
SET DGSUB1=$ORDER(@DGLIST@(DGSUB1))
if DGSUB1=""
QUIT
Begin DoDot:2
+27 DO PRINT1(DGSUB1)
End DoDot:2
if DGQ
QUIT
+28 if DGQ
QUIT
+29 WRITE !
DO PAUSE^DGOTHRP2(.DGQ)
if DGQ
QUIT
WRITE !
End DoDot:1
+30 if DGQ
QUIT
+31 DO HEAD
DO RPTSUM
+32 QUIT
+33 ;
+34 ;DG*5.3*977 OTH-EXT
PRINT1(DGSUB1) ;Print or display report by division
+1 FOR
SET DGSUB2=$ORDER(@DGLIST@(DGSUB1,DGSUB2))
if DGSUB2=""
QUIT
Begin DoDot:1
+2 FOR
SET DGSUB3=$ORDER(@DGLIST@(DGSUB1,DGSUB2,DGSUB3))
if DGSUB3=""
QUIT
Begin DoDot:2
+3 IF 2[$PIECE(DGSORT("REPORT"),U)
if DGQ
QUIT
DO PRNTFC
QUIT
+4 FOR
SET DGSUB4=$ORDER(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4))
if DGSUB4=""
QUIT
Begin DoDot:3
+5 KILL DGSTR
+6 IF $PIECE(DGSORT("DGSRTBY"),U)=3
IF 1[$PIECE(DGSORT("REPORT"),U)
if DGQ
QUIT
Begin DoDot:4
+7 FOR
SET DGSUB5=$ORDER(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4,DGSUB5))
if DGSUB5=""
QUIT
Begin DoDot:5
+8 SET DGSTR=$GET(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4,DGSUB5))
DO PRINT2
+9 QUIT
End DoDot:5
if DGQ
QUIT
+10 QUIT
End DoDot:4
QUIT
+11 IF $GET(DGSTR)=""
SET DGSTR=$GET(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4))
+12 DO PRINT2
SET DGNEWDIV=0
End DoDot:3
if DGQ
QUIT
+13 QUIT
End DoDot:2
if DGQ
QUIT
+14 QUIT
End DoDot:1
if DGQ
QUIT
+15 if DGQ
QUIT
+16 IF DGDIV'=DGSUB1
IF 1[$PIECE(DGSORT("REPORT"),U)
WRITE !
DO PAUSE^DGOTHRP2(.DGQ)
if DGQ
QUIT
WRITE !
+17 QUIT
+18 ;
PRINT2 ;
+1 WRITE !
+2 IF $Y>(IOSL-4)
DO PAUSE(.DGQ)
if DGQ
QUIT
DO HEAD
WRITE !
DO DVISION(DGSUB1)
WRITE !
IF DGOLD=DGSUB2
DO PTNAME
+3 IF $PIECE(DGSORT("DGSRTBY"),U)=1
IF DGNEWDIV!(DGSUB2'=DGOLD)
DO PTNAME
SET DGOLD=DGSUB2
SET DGOLD365=""
+4 IF $PIECE(DGSORT("DGSRTBY"),U)=2!($PIECE(DGSORT("DGSRTBY"),U)=3)
IF DGNEWDIV!(DGSUB4'=DGOLD)
WRITE $EXTRACT(DGSUB4,1,18),?20,$PIECE(DGSTR,U,2)
SET DGOLD=DGSUB4
SET DGOLD365=""
+5 IF DGNEWDIV!(DGSUB3'=DGOLD365)
WRITE ?27,DGSUB3
SET DGOLD365=DGSUB3
+6 WRITE ?31,$PIECE(DGSTR,U),?35,$PIECE(DGSTR,U,3),?47,$PIECE(DGSTR,U,4),?59,$PIECE(DGSTR,U,5),?65,$EXTRACT($PIECE(DGSTR,U,6),1,15)
+7 QUIT
+8 ;
PTNAME ;diplay patient and PID
+1 WRITE $EXTRACT(DGSUB2,1,18),?20,$PIECE(DGSTR,U,2)
+2 QUIT
+3 ;
+4 ;DG*5.3*977 OTH-EXT
PRNTFC ;Print or display report by facility
+1 KILL DGSTR
+2 IF $PIECE(DGSORT("DGSRTBY"),U)=3
if DGQ
QUIT
Begin DoDot:1
+3 FOR
SET DGSUB4=$ORDER(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4))
if DGSUB4=""
QUIT
Begin DoDot:2
+4 SET DGSTR=$GET(@DGLIST@(DGSUB1,DGSUB2,DGSUB3,DGSUB4))
+5 DO PRNTFC1
End DoDot:2
if DGQ
QUIT
End DoDot:1
QUIT
+6 IF $GET(DGSTR)=""
SET DGSTR=$GET(@DGLIST@(DGSUB1,DGSUB2,DGSUB3))
+7 DO PRNTFC1
+8 QUIT
+9 ;
PRNTFC1 ;
+1 WRITE !
+2 IF $Y>(IOSL-4)
DO PAUSE(.DGQ)
if DGQ
QUIT
DO HEAD
WRITE !
+3 IF $PIECE(DGSORT("DGSRTBY"),U)=1
IF DGSUB1'=DGOLD
WRITE $EXTRACT(DGSUB1,1,18),?20,$PIECE(DGSTR,U,2)
SET DGOLD=DGSUB1
SET DGOLD365=""
+4 IF $PIECE(DGSORT("DGSRTBY"),U)=2!($PIECE(DGSORT("DGSRTBY"),U)=3)
IF DGSUB3'=DGOLD
WRITE $EXTRACT(DGSUB3,1,18),?20,$PIECE(DGSTR,U,2)
SET DGOLD=DGSUB3
SET DGOLD365=""
+5 IF DGSUB2'=DGOLD365
WRITE ?27,DGSUB2
SET DGOLD365=DGSUB2
+6 WRITE ?31,$PIECE(DGSTR,U),?35,$PIECE(DGSTR,U,3),?47,$PIECE(DGSTR,U,4),?59,$PIECE(DGSTR,U,5),?65,$EXTRACT($PIECE(DGSTR,U,6),1,15)
+7 if DGQ
QUIT
+8 QUIT
+9 ;
RPTSUM ;Display report summary
+1 WRITE !!,"REPORT SUMMARY:"
+2 WRITE !,"==============="
+3 WRITE !!,"Total "_$SELECT(1[$PIECE(DGSORT("DGSTATUS"),U):"Active",2[$PIECE(DGSORT("DGSTATUS"),U):"Expired",1:"Active/Expired")
+4 WRITE " OTH 90-DAY PERIOD from ",$$FMTE^XLFDT($GET(DGSORT("DGBEG")),"5Z")
+5 WRITE " to ",$$FMTE^XLFDT($GET(DGSORT("DGEND")),"5Z"),":",$JUSTIFY($SELECT(DGTOTAL>0:DGTOTAL,1:0),4),!
+6 WRITE !,"<END OF REPORT>"
+7 DO ASKCONT^DGOTHMG2
+8 QUIT
+9 ;
+10 ;DG*5.3*977 OTH-EXT
DVISION(DGFAC) ;
+1 WRITE "Division: ",DGSORT("DIVISION",DGOEIEN,DGFAC)_" ("_DGFAC_")",!
+2 QUIT
+3 ;
HEAD ;Print/Display Page Header
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,DGQ)=1
QUIT
+2 NEW DGFACLTY
+3 IF TRM!('TRM&DGPAGE)
WRITE @IOF
+4 SET DGPAGE=$GET(DGPAGE)+1
+5 SET DGFACLTY="Facility: "_$PIECE(HERE,U,2)
+6 WRITE !,?80-$LENGTH(ZTDESC)\2,$GET(ZTDESC),?71,"Page:",?77,DGPAGE
+7 WRITE !,?80-$LENGTH(DGFACLTY)\2,DGFACLTY
+8 WRITE !,"Date Range:",?12,$$FMTE^XLFDT(DGSORT("DGBEG"),"5Z")_" TO "_$$FMTE^XLFDT(DGSORT("DGEND"),"5Z")
+9 WRITE ?45,"Sorted By:",?56,$SELECT(2[$PIECE(DGSORT("REPORT"),U):"",1:$PIECE(DGSORT("REPORT"),U,2)_","),$PIECE($GET(DGSORT("DGSRTBY")),U,2)
+10 WRITE !,"Status :",?12,$PIECE($GET(DGSORT("DGSTATUS")),U,2)
+11 WRITE ?45,"Printed :",?56,$$FMTE^XLFDT($$NOW^XLFDT,"MP")
+12 WRITE !,DDASH
+13 WRITE !,"PATIENT NAME",?20,"PID",?26,"365",?31,"90",?35,"START DATE",?47,"END DATE",?59,"DAYS",?65,"AUTHORIZED BY"
+14 WRITE !,?26,"PRD",?31,"PRD",?59,"LEFT"
+15 WRITE !,DDASH
+16 QUIT
+17 ;
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 ;tell TaskMan to delete Task log entry
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+3 IF 'TRM
IF $Y>0
WRITE @IOF
+4 KILL %ZIS,POP
+5 DO ^%ZISC
DO HOME^%ZIS
End DoDot:1
+6 QUIT
