DGOTHRP5 ;SLC/RED,RM - OTHD (OTHER THAN HONORABLE DISCHARGE) Reports ;April 03,2019@10:16
;;5.3;Registration;**952,977**;4/30/19;Build 177
;;Per VA Directive 6402, this routine should not be modified.
;
;IA's
; 10015 Sup GETS^DIQ
; 10103 Sup ^XLFDT: $$FMTE, $$NOW
; 10026 Sup ^DIR
; 10063 Sup ^%ZTLOAD
; 10104 Sup $$CJ^XLFSTR
; 10024 Sup WAIT^DICD
; 10112 Sup $$SITE^VASITE
; 10003 Sup %DT
; 10089 Sup %ZISC
;
Q ; No direct access
;
EN ;entry point from Menu Option: DGOTH OTH-90 STATUS REPORTS
N DGIEN33,NAME,PID,PROMPT,DGRTYP,DGRET,PAGE,DGDTFRM,DGDTTO,DGARR,DGERR,DGDIV,NAME,PID,ZTSK,DGDTFRMTO,DASH,DGREM,SET,EXIT
N ZTSAVE ;open array reference of input parameters used by tasking
N ZTDESC ;contains the free-text description of your task that you passed to the Program Interface
N ZTQUEUED ;background execution
N ZTREQ ;post-execution
N ZTSTOP
N ZTRTN
N ZTSK
N VAUTD,Y ; variables for DIVISION^VAUTOMA
N DGSORT ;array or report parameters
N DGENCTR ;array for the outpatient encounter
N HERE
;check for database
;DG*5.3*977 OTH-EXT
I '+$O(^DGOTH(33,"B","")) W !,$$CJ^XLFSTR(">>> No OTH-90 records have been found. <<<",80) D ASKCONT^DGOTHMG2 Q
S DGRET=$NA(^TMP("DGOTHRP5",$J)) K @DGRET,DGSORT,VAUTD
S (EXIT,DGIEN33,PAGE)=0
W @IOF
W !,"OTH 90-DAY PERIOD AUTHORIZATION REPORT"
W !!,"This option generates a report that prints a listing of OTH-90 patients who"
W !,"have an Outpatient Encounter with STATUS=CHECKED OUT for Clinic(s) associated"
W !,"with the selected Division(s) within the user-specified date range in which"
W !,"their 90-Day period of care has been APPROVED, PENDING or DENIED."
S PROMPT="Please select OTH-90 Authorization report type",SET="S^1:Approved;2:Pending;3:Denied"
S DGRTYP=$$SELECT(PROMPT,SET)
I 'Y G OUT ;quit if no selection
I Y S DGRTYP=$S(Y=1:"APPROV",Y=2:"PEND",1:"DENIED")
S DGDTFRMTO=$$DTFRMTO("Select dates")
Q:DGDTFRMTO=0
;
;DG*5.3*977 OTH-EXT
;prompt user to select DIVISION
W !!,"Please select divisions to include in the report"
I '$$SELDIV^DGOTHRP1 Q
;DGSORT("DIVISION")=0 -- user only select one division
;DGSORT("DIVISION")=1 -- user select ALL division
;DGSORT("DIVISION")>1 -- user select multiple division but not all
;if user selected division is many or all but not one
;prompt user on how the report will be sorted
I DGSORT("DIVISION")>0,'$$SORTRPT^DGOTHRP1 Q
I DGSORT("DIVISION")=0 S DGSORT("REPORT")="1^Patient Name" ;default to sort report by divisions
;prompt for device
W !
S ZTSAVE("DGSORT(")=""
S X="OTH-90 AUTHORIZATION REPORT"
D EN^XUTMDEVQ("DQ^DGOTHRP5",X,.ZTSAVE)
D HOME^%ZIS
Q
;
DQ ;
I $E(IOST)="C" D WAIT^DICD
S HERE=$$SITE^VASITE ;extract the IEN and facility name
N TRM S TRM=($E(IOST)="C")
N DGDFN
S DGDFN=""
F S DGDFN=$O(^DGOTH(33,"B",DGDFN)) Q:DGDFN="" D
. ; Start search logic here and then head to reports
. S DGIEN33=$$HASENTRY^DGOTHD2(DGDFN)
. K DGARR,DGERR D GETS^DIQ(33,DGIEN33_",",".01;.02;.06;.07;1*","EI","DGARR","DGERR")
. Q:$D(DGERR)
. Q:DGARR(33,DGIEN33_",",.02,"I")=0
. ;DG*5.3*977 OTH-EXT
. ;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^DGOTHRP2(DGDFN)
. N NAME,PID,DGDIV S PID=$$GET1^DIQ(2,DGARR(33,DGIEN33_",",.01,"I"),".0905","E"),NAME=DGARR(33,DGIEN33_",",.01,"E")
. D @DGRTYP
D PRINT,OUT
Q
;
APPROV ;Approved authorizations
N DG90A,DGRES9,DG365,DGDATA
D CLOCK^DGOTHINQ(DGIEN33)
Q:'$D(DG90A(2))
S DG365=$$LASTPRD^DGOTHUT1(DGIEN33)
N DGPER S DGPER=1 F DGPER=2:1:$P(DG365,U,3) D
. S DGDATA=$$GETAUTH^DGOTHUT1(DGIEN33,$P(DG365,U),DGPER),DGDIV=$P(DGDATA,U,9)
. Q:$P(DGDATA,U,8)="" ;Not authorized yet
. I DGDIV="" S DGDIV="UNKN"
. I $P(DGDATA,U,3)<DGDTFRM!($P(DGDATA,U,3)>DGDTTO) Q ;Not within the date range
. Q:'$$CHECKOE() ;check if there any Outpatient Encounter entry for this patient
. D BUILD
Q
;
CHECKOE() ;check if there any Outpatient Encounter entry for this patient
K DGENCTR
D CHKTREAT^DGPPRP1(.DGENCTR,+DGDFN,DGDTFRM,DGDTTO,.VAUTD)
Q $S('$D(DGENCTR):0,1:1)
;
BUILD ;Build data either by Division or Facility
N DGDIVOE,DGSDT,TMPDIV
S (DGDIVOE,DGSDT,TMPDIV)=""
F S DGDIVOE=$O(DGENCTR(DGDIVOE)) Q:DGDIVOE="" D
. F S DGSDT=$O(DGENCTR(DGDIVOE,DGSDT)) Q:DGSDT="" D
. . S TMPDIV=$P(DGENCTR(DGDIVOE,DGSDT),U,2)
. . I TMPDIV="" S TMPDIV=$S($P(^DG(40.8,DGDIVOE,0),U,2)="":"UNKNOWN",1:$P(^DG(40.8,DGDIVOE,0),U,2))
. . I TMPDIV["UNKNOWN" S DGSORT("DIVISION",DGDIVOE,TMPDIV)=$P(DGENCTR(DGDIVOE,DGSDT),U)
. . I 1[$P(DGSORT("REPORT"),U),'$D(@DGRET@(TMPDIV)) S @DGRET@(TMPDIV)=DGENCTR(DGDIVOE,DGSDT)
. . I DGRTYP="APPROV" D
. . . S @DGRET@(TMPDIV,NAME,DGPER)=NAME_U_PID_U_$$FMTE^XLFDT($P($P(DGDATA,U,4),"."),"5Z")_U_$$FMTE^XLFDT($P($P(DGDATA,U,5),"."),"5Z")_U_$$FMTE^XLFDT($P($P(DGDATA,U,3),"."),"5Z")_U_$P(DGDATA,U,8)
. . I DGRTYP="PEND" D
. . . S @DGRET@(TMPDIV,NAME)=NAME_U_PID_U_$$FMTE^XLFDT($P(DGRES9,U,2),"5Z")_U_DGREM
. . I DGRTYP="DENIED" D
. . . S @DGRET@(TMPDIV,NAME,SEQ)=NAME_U_PID_U_$$FMTE^XLFDT($P(DGRES,U,2),"5Z")_U_DGREAS
Q
;
PEND ; Pending Requests
Q:DGARR(33,DGIEN33_",",.07,"I")=""
N DG90A,DGRES9 S DGRES9=$$GETPEND^DGOTHUT1(DGARR(33,DGIEN33_",",.01,"I"))
Q:DGRES9<1
S DGDIV=$P(DGRES9,U,5),DGREM=$$FMDIFF^XLFDT(DT,$P(DGRES9,U,2),1)
I $P(DGRES9,U,2)<DGDTFRM!($P(DGRES9,U,2)>DGDTTO) Q ;Not within the date range
Q:'$$CHECKOE() ;check if there any Outpatient Encounter entry for this patient
D BUILD
Q
;
DENIED ;Denied requests
N SEQ,DGRES
Q:'$D(^DGOTH(33,DGIEN33,3))
N DGLDEN,DGDIV,DGREAS S DGLDEN=999,DGLDEN=$O(^DGOTH(33,DGIEN33,3,"B",DGLDEN),-1)
F SEQ=1:1:DGLDEN D
. S DGRES=$$GETDEN^DGOTHUT1(DGIEN33,SEQ)
. Q:DGRES<1
. I $P(DGRES,U,2)<DGDTFRM!($P(DGRES,U,2)>DGDTTO) Q ;Not within the date range
. Q:'$$CHECKOE() ;check if there any Outpatient Encounter entry for this patient
. S DGDIV=$P(DGRES,U,6),DGREAS=$P(DGRES,U,3)
. D BUILD
Q
;
HDR ; Print page header
S PAGE=$G(PAGE)+1
W @IOF W ?15,"Other Than Honorable '",$S(DGRTYP="APPROV":"APPROVED",DGRTYP="PEND":"PENDING",1:"DENIED"),"' Authorizations",?70,"Page: ",PAGE
W !?15,"Selected date range: ",$$FMTE^XLFDT(DGDTFRM,"5Z")," to ",$$FMTE^XLFDT(DGDTTO,"5Z"),!
W "Facility: "_$P(HERE,U,2),?51,"Sorted By: ",$P(DGSORT("REPORT"),U,2),!
F DASH=1:1:80 W "-"
I DGRTYP="APPROV" D
. W !,"Name",?23,"PID",?30,"Date Req.",?42,"Date Auth.",?54,"90-Day",?66,"Authorized By"
. W !,?30,"Submitted",?42,"Received",?54,"Start DT",!
I DGRTYP="PEND" W !,"Name",?33,"PID",?41,"Pending Auth.",?58,"# of Days Auth.",!,?41,"Request Date",?58,"is Pending",!
I DGRTYP="DENIED" W !,"Name",?24,"PID",?31,"Date Request",?45,"Authorization Comment",!,?31,"Submitted",!
F DASH=1:1:80 W "-"
;
Q
;
PRINT ;Print out results
N DGFAC,DGOLDIV,FACILITY,DGPTLIST,DGOEIEN
S DGOLDIV=""
K DGPTLIST
I '$D(@DGRET) D HDR W !!," >>> No records were found using the report criteria.",! G OUT
I 2[$P(DGSORT("REPORT"),U) D
. D HDR
. S DGFAC=0 F S DGFAC=$O(@DGRET@(DGFAC)) Q:DGFAC=""!(EXIT) D PRINT1 Q:EXIT
E D
. S DGOEIEN="" F S DGOEIEN=$O(DGSORT("DIVISION",DGOEIEN)) Q:DGOEIEN="" D Q:EXIT
. . S DGFAC="" F S DGFAC=$O(DGSORT("DIVISION",DGOEIEN,DGFAC)) Q:DGFAC="" D Q:EXIT
. . . D HDR,DVISION
. . . I '$D(@DGRET@(DGFAC)) D Q
. . . . W !," >>> No records were found for this Division.",!!
. . . . I ($E(IOST,1,2)="C-")&(IO=IO(0)) S DIR(0)="E" D ^DIR K DIR D
. . . . . I $D(DTOUT)!($D(DUOUT)) S EXIT=1 G OUT
. . . D PRINT1
Q:EXIT
I $E(IOST,1,2)="C-" R !!?8,"End of the Report...Press Enter to Continue",X:DTIME W @IOF
Q
;
;DG*5.3*977 OTH-EXT
DVISION ;
W "Division: ",DGSORT("DIVISION",DGOEIEN,DGFAC)_" ("_DGFAC_")",!
Q
;
PRINT1 ;Print out results
N DGOLDNM,SEQ
S DGOLDNM=""
N NAME,DGPER
S NAME="" F S NAME=$O(@DGRET@(DGFAC,NAME)) Q:NAME="" D
. I DGRTYP="APPROV" D Q
. . S DGPER=0 F S DGPER=$O(@DGRET@(DGFAC,NAME,DGPER)) Q:DGPER="" D
. . . I $Y+3>IOSL I ($E(IOST,1,2)="C-")&(IO=IO(0)) S DIR(0)="E" D ^DIR K DIR D
. . . . I $D(DTOUT)!($D(DUOUT)) S EXIT=1 G OUT
. . . . D HDR
. . . . I 1[$P(DGSORT("REPORT"),U) D DVISION
. . . . I DGOLDNM=NAME W !,$E(NAME,1,22),?23,$P(@DGRET@(DGFAC,NAME,DGPER),U,2)
. . . I 'EXIT D
. . . . ;do not display the patient's name twice is sort by facility is selected
. . . . I 2[$P(DGSORT("REPORT"),U),$D(DGPTLIST(NAME,DGPER)) Q
. . . . ;display the patient name and PID once only
. . . . I DGOLDNM'=NAME W !,$E(NAME,1,22),?23,$P(@DGRET@(DGFAC,NAME,DGPER),U,2) S DGOLDNM=NAME
. . . . W ?30,$P(@DGRET@(DGFAC,NAME,DGPER),U,3),?42,$P(@DGRET@(DGFAC,NAME,DGPER),U,4),?54,$P(@DGRET@(DGFAC,NAME,DGPER),U,5)
. . . . W ?66,$E($P(@DGRET@(DGFAC,NAME,DGPER),U,6),1,14),!
. . . I 2[$P(DGSORT("REPORT"),U),'$D(DGPTLIST(NAME,DGPER)) S DGPTLIST(NAME,DGPER)=""
. I DGRTYP="PEND" D Q
. . I $Y+3>IOSL I ($E(IOST,1,2)="C-")&(IO=IO(0)) S DIR(0)="E" D ^DIR K DIR D
. . . I $D(DTOUT)!($D(DUOUT)) S EXIT=1 G OUT
. . . D HDR
. . I 'EXIT D
. . . ;do not display the patient's name twice is sort by facility is selected
. . . I 2[$P(DGSORT("REPORT"),U),$D(DGPTLIST(NAME)) Q
. . . W !,$E(NAME,1,30),?33,$P(@DGRET@(DGFAC,NAME),U,2),?41,$P(@DGRET@(DGFAC,NAME),U,3),?60,$J($P(@DGRET@(DGFAC,NAME),U,4),5)
. . I 2[$P(DGSORT("REPORT"),U),'$D(DGPTLIST(NAME)) S DGPTLIST(NAME)=""
. I DGRTYP="DENIED" D Q
. . S SEQ=0 F S SEQ=$O(@DGRET@(DGFAC,NAME,SEQ)) Q:SEQ="" D
. . . I $Y+3>IOSL I ($E(IOST,1,2)="C-")&(IO=IO(0)) S DIR(0)="E" D ^DIR K DIR D
. . . . I $D(DTOUT)!($D(DUOUT)) S EXIT=1 G OUT
. . . . D HDR
. . . I 'EXIT D
. . . . ;do not display the patient's name twice is sort by facility is selected
. . . . I 2[$P(DGSORT("REPORT"),U),$D(DGPTLIST(NAME,SEQ)) Q
. . . . ;display the patient name and PID once only
. . . . I DGOLDNM'=NAME W !,$E(NAME,1,22),?24,$P(@DGRET@(DGFAC,NAME,SEQ),U,2) S DGOLDNM=NAME
. . . . W ?31,$P(@DGRET@(DGFAC,NAME,SEQ),U,3),?45,$E($P(@DGRET@(DGFAC,NAME,SEQ),U,4),1,35),!
. . . I 2[$P(DGSORT("REPORT"),U),'$D(DGPTLIST(NAME)) S DGPTLIST(NAME,SEQ)=""
Q:EXIT
I 1[$P(DGSORT("REPORT"),U) I ($E(IOST,1,2)="C-")&(IO=IO(0)) S DIR(0)="E" W ! D ^DIR K DIR D
. I $D(DTOUT)!($D(DUOUT)) S EXIT=1 G OUT W !
Q
;
DTFRMTO(PROMPT) ;Get from and to dates
N %DT,Y,X,DTOUT,OUT,DIRUT,DUOUT,DIROUT,STATUS,STDT,STATUS
;INPUT ; PROMPT - Message to display prior to prompting for dates
;OUTPUT: 1^BEGDT^ENDDT - Data found
; 0 - User up arrowed or timed out
;If they want to show first available date for that set of Status, use this sub
INDT ;
S OUT=0
S DIR(0)="DO^"_DT_":"_DT_":EX"
S %DT="AEX",%DT("A")="Starting date - From: " ;Enter Beginning Date: "
W ! D ^%DT K %DT
I Y<0 W !!,"No Date selected, quitting. ",!! Q OUT ;Quit if user time out or didn't enter valid date
I Y>DT W !!,"Future dates are not allowed, please re-enter" K Y,%DT G INDT ;Future dates not allowed
S DGDTFRM=+Y
TODT S %DT="AEX",%DT("A")=" Ending date - TO: ",%DT("B")="T" ; Get end date, default is "TODAY"
D ^%DT K %DT
;Quit if user time out or didn't enter valid date
I Y<0 W !!,"No Date selected, quitting. ",!! Q OUT
I Y<DGDTFRM W !!,"Ending date must be greater than or equal to the start date",!! K Y,%DT G TODT
S DGDTTO=+Y,OUT=1_U_DGDTFRM_U_DGDTTO
;Switch dates if Begin Date is more recent than End Date
S:DGDTFRM>DGDTTO OUT=1_U_DGDTTO_U_DGDTFRM
Q OUT
;
SELECT(PROMPT,SET) ; prompts for a report type
;INPUT:
S DIR(0)=SET,DIR("A")=PROMPT,DIR("B")=1,DIR("?")="^D HELP^DGOTHRP5(1)",DIR("??")=DIR("?") D ^DIR K DIR
Q:Y<0 OUT
Q Y
;
OUT ; KILL RETURN ARRAY QUIT
D ^%ZISC
K @DGRET
Q
;
;DG*5.3*977 OTH-EXT
HELP(DGSEL) ;OTH-90 Authorization Report help text
I DGSEL=1 D
. W !," Please ENTER:",!
. D TEXT
. W !," 1 = That have been 'APPROVED' for an additional 90-Day"
. W !," period of care."
. W !," 2 = Whose request for an additional 90-Day period of"
. W !," care is waiting to be approved or denied."
. W !," 3 = Whose request for an additional 90-Day period of"
. W !," care has been DENIED."
Q
;
;DG*5.3*977 OTH-EXT
TEXT ;
W !," If you wish to print a list(s) of OTH-90 MH Care"
W !," patient who have an Outpatient Encounter with"
W !," STATUS=CHECKED OUT for selected Division within"
W !," the user-specified date range.",!
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGOTHRP5 12644 printed Sep 23, 2025@20:22:54 Page 2
DGOTHRP5 ;SLC/RED,RM - OTHD (OTHER THAN HONORABLE DISCHARGE) Reports ;April 03,2019@10:16
+1 ;;5.3;Registration;**952,977**;4/30/19;Build 177
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;IA's
+5 ; 10015 Sup GETS^DIQ
+6 ; 10103 Sup ^XLFDT: $$FMTE, $$NOW
+7 ; 10026 Sup ^DIR
+8 ; 10063 Sup ^%ZTLOAD
+9 ; 10104 Sup $$CJ^XLFSTR
+10 ; 10024 Sup WAIT^DICD
+11 ; 10112 Sup $$SITE^VASITE
+12 ; 10003 Sup %DT
+13 ; 10089 Sup %ZISC
+14 ;
+15 ; No direct access
QUIT
+16 ;
EN ;entry point from Menu Option: DGOTH OTH-90 STATUS REPORTS
+1 NEW DGIEN33,NAME,PID,PROMPT,DGRTYP,DGRET,PAGE,DGDTFRM,DGDTTO,DGARR,DGERR,DGDIV,NAME,PID,ZTSK,DGDTFRMTO,DASH,DGREM,SET,EXIT
+2 ;open array reference of input parameters used by tasking
NEW ZTSAVE
+3 ;contains the free-text description of your task that you passed to the Program Interface
NEW ZTDESC
+4 ;background execution
NEW ZTQUEUED
+5 ;post-execution
NEW ZTREQ
+6 NEW ZTSTOP
+7 NEW ZTRTN
+8 NEW ZTSK
+9 ; variables for DIVISION^VAUTOMA
NEW VAUTD,Y
+10 ;array or report parameters
NEW DGSORT
+11 ;array for the outpatient encounter
NEW DGENCTR
+12 NEW HERE
+13 ;check for database
+14 ;DG*5.3*977 OTH-EXT
+15 IF '+$ORDER(^DGOTH(33,"B",""))
WRITE !,$$CJ^XLFSTR(">>> No OTH-90 records have been found. <<<",80)
DO ASKCONT^DGOTHMG2
QUIT
+16 SET DGRET=$NAME(^TMP("DGOTHRP5",$JOB))
KILL @DGRET,DGSORT,VAUTD
+17 SET (EXIT,DGIEN33,PAGE)=0
+18 WRITE @IOF
+19 WRITE !,"OTH 90-DAY PERIOD AUTHORIZATION REPORT"
+20 WRITE !!,"This option generates a report that prints a listing of OTH-90 patients who"
+21 WRITE !,"have an Outpatient Encounter with STATUS=CHECKED OUT for Clinic(s) associated"
+22 WRITE !,"with the selected Division(s) within the user-specified date range in which"
+23 WRITE !,"their 90-Day period of care has been APPROVED, PENDING or DENIED."
+24 SET PROMPT="Please select OTH-90 Authorization report type"
SET SET="S^1:Approved;2:Pending;3:Denied"
+25 SET DGRTYP=$$SELECT(PROMPT,SET)
+26 ;quit if no selection
IF 'Y
GOTO OUT
+27 IF Y
SET DGRTYP=$SELECT(Y=1:"APPROV",Y=2:"PEND",1:"DENIED")
+28 SET DGDTFRMTO=$$DTFRMTO("Select dates")
+29 if DGDTFRMTO=0
QUIT
+30 ;
+31 ;DG*5.3*977 OTH-EXT
+32 ;prompt user to select DIVISION
+33 WRITE !!,"Please select divisions to include in the report"
+34 IF '$$SELDIV^DGOTHRP1
QUIT
+35 ;DGSORT("DIVISION")=0 -- user only select one division
+36 ;DGSORT("DIVISION")=1 -- user select ALL division
+37 ;DGSORT("DIVISION")>1 -- user select multiple division but not all
+38 ;if user selected division is many or all but not one
+39 ;prompt user on how the report will be sorted
+40 IF DGSORT("DIVISION")>0
IF '$$SORTRPT^DGOTHRP1
QUIT
+41 ;default to sort report by divisions
IF DGSORT("DIVISION")=0
SET DGSORT("REPORT")="1^Patient Name"
+42 ;prompt for device
+43 WRITE !
+44 SET ZTSAVE("DGSORT(")=""
+45 SET X="OTH-90 AUTHORIZATION REPORT"
+46 DO EN^XUTMDEVQ("DQ^DGOTHRP5",X,.ZTSAVE)
+47 DO HOME^%ZIS
+48 QUIT
+49 ;
DQ ;
+1 IF $EXTRACT(IOST)="C"
DO WAIT^DICD
+2 ;extract the IEN and facility name
SET HERE=$$SITE^VASITE
+3 NEW TRM
SET TRM=($EXTRACT(IOST)="C")
+4 NEW DGDFN
+5 SET DGDFN=""
+6 FOR
SET DGDFN=$ORDER(^DGOTH(33,"B",DGDFN))
if DGDFN=""
QUIT
Begin DoDot:1
+7 ; Start search logic here and then head to reports
+8 SET DGIEN33=$$HASENTRY^DGOTHD2(DGDFN)
+9 KILL DGARR,DGERR
DO GETS^DIQ(33,DGIEN33_",",".01;.02;.06;.07;1*","EI","DGARR","DGERR")
+10 if $DATA(DGERR)
QUIT
+11 if DGARR(33,DGIEN33_",",.02,"I")=0
QUIT
+12 ;DG*5.3*977 OTH-EXT
+13 ;Patient's primary eligibility code is no longer EXPANDED MH CARE NON-ENROLLEE
+14 if $$ISOTHD^DGOTHD(DGDFN)=0
QUIT
+15 ;Patient's current MH CARE TYPE is no longer OTH-90
+16 if '$$ISOTH90^DGOTHRP2(DGDFN)
QUIT
+17 NEW NAME,PID,DGDIV
SET PID=$$GET1^DIQ(2,DGARR(33,DGIEN33_",",.01,"I"),".0905","E")
SET NAME=DGARR(33,DGIEN33_",",.01,"E")
+18 DO @DGRTYP
End DoDot:1
+19 DO PRINT
DO OUT
+20 QUIT
+21 ;
APPROV ;Approved authorizations
+1 NEW DG90A,DGRES9,DG365,DGDATA
+2 DO CLOCK^DGOTHINQ(DGIEN33)
+3 if '$DATA(DG90A(2))
QUIT
+4 SET DG365=$$LASTPRD^DGOTHUT1(DGIEN33)
+5 NEW DGPER
SET DGPER=1
FOR DGPER=2:1:$PIECE(DG365,U,3)
Begin DoDot:1
+6 SET DGDATA=$$GETAUTH^DGOTHUT1(DGIEN33,$PIECE(DG365,U),DGPER)
SET DGDIV=$PIECE(DGDATA,U,9)
+7 ;Not authorized yet
if $PIECE(DGDATA,U,8)=""
QUIT
+8 IF DGDIV=""
SET DGDIV="UNKN"
+9 ;Not within the date range
IF $PIECE(DGDATA,U,3)<DGDTFRM!($PIECE(DGDATA,U,3)>DGDTTO)
QUIT
+10 ;check if there any Outpatient Encounter entry for this patient
if '$$CHECKOE()
QUIT
+11 DO BUILD
End DoDot:1
+12 QUIT
+13 ;
CHECKOE() ;check if there any Outpatient Encounter entry for this patient
+1 KILL DGENCTR
+2 DO CHKTREAT^DGPPRP1(.DGENCTR,+DGDFN,DGDTFRM,DGDTTO,.VAUTD)
+3 QUIT $SELECT('$DATA(DGENCTR):0,1:1)
+4 ;
BUILD ;Build data either by Division or Facility
+1 NEW DGDIVOE,DGSDT,TMPDIV
+2 SET (DGDIVOE,DGSDT,TMPDIV)=""
+3 FOR
SET DGDIVOE=$ORDER(DGENCTR(DGDIVOE))
if DGDIVOE=""
QUIT
Begin DoDot:1
+4 FOR
SET DGSDT=$ORDER(DGENCTR(DGDIVOE,DGSDT))
if DGSDT=""
QUIT
Begin DoDot:2
+5 SET TMPDIV=$PIECE(DGENCTR(DGDIVOE,DGSDT),U,2)
+6 IF TMPDIV=""
SET TMPDIV=$SELECT($PIECE(^DG(40.8,DGDIVOE,0),U,2)="":"UNKNOWN",1:$PIECE(^DG(40.8,DGDIVOE,0),U,2))
+7 IF TMPDIV["UNKNOWN"
SET DGSORT("DIVISION",DGDIVOE,TMPDIV)=$PIECE(DGENCTR(DGDIVOE,DGSDT),U)
+8 IF 1[$PIECE(DGSORT("REPORT"),U)
IF '$DATA(@DGRET@(TMPDIV))
SET @DGRET@(TMPDIV)=DGENCTR(DGDIVOE,DGSDT)
+9 IF DGRTYP="APPROV"
Begin DoDot:3
+10 SET @DGRET@(TMPDIV,NAME,DGPER)=NAME_U_PID_U_$$FMTE^XLFDT($PIECE($PIECE(DGDATA,U,4),"."),"5Z")_U_$$FMTE^XLFDT($PIECE($PIECE(DGDATA,U,5),"."),"5Z")_U_$$FMTE^XLFDT($PIECE($PIECE(DGDATA,U,3),"."),"5Z")_U_$PIECE(DGDATA,U,8)
End DoDot:3
+11 IF DGRTYP="PEND"
Begin DoDot:3
+12 SET @DGRET@(TMPDIV,NAME)=NAME_U_PID_U_$$FMTE^XLFDT($PIECE(DGRES9,U,2),"5Z")_U_DGREM
End DoDot:3
+13 IF DGRTYP="DENIED"
Begin DoDot:3
+14 SET @DGRET@(TMPDIV,NAME,SEQ)=NAME_U_PID_U_$$FMTE^XLFDT($PIECE(DGRES,U,2),"5Z")_U_DGREAS
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
PEND ; Pending Requests
+1 if DGARR(33,DGIEN33_",",.07,"I")=""
QUIT
+2 NEW DG90A,DGRES9
SET DGRES9=$$GETPEND^DGOTHUT1(DGARR(33,DGIEN33_",",.01,"I"))
+3 if DGRES9<1
QUIT
+4 SET DGDIV=$PIECE(DGRES9,U,5)
SET DGREM=$$FMDIFF^XLFDT(DT,$PIECE(DGRES9,U,2),1)
+5 ;Not within the date range
IF $PIECE(DGRES9,U,2)<DGDTFRM!($PIECE(DGRES9,U,2)>DGDTTO)
QUIT
+6 ;check if there any Outpatient Encounter entry for this patient
if '$$CHECKOE()
QUIT
+7 DO BUILD
+8 QUIT
+9 ;
DENIED ;Denied requests
+1 NEW SEQ,DGRES
+2 if '$DATA(^DGOTH(33,DGIEN33,3))
QUIT
+3 NEW DGLDEN,DGDIV,DGREAS
SET DGLDEN=999
SET DGLDEN=$ORDER(^DGOTH(33,DGIEN33,3,"B",DGLDEN),-1)
+4 FOR SEQ=1:1:DGLDEN
Begin DoDot:1
+5 SET DGRES=$$GETDEN^DGOTHUT1(DGIEN33,SEQ)
+6 if DGRES<1
QUIT
+7 ;Not within the date range
IF $PIECE(DGRES,U,2)<DGDTFRM!($PIECE(DGRES,U,2)>DGDTTO)
QUIT
+8 ;check if there any Outpatient Encounter entry for this patient
if '$$CHECKOE()
QUIT
+9 SET DGDIV=$PIECE(DGRES,U,6)
SET DGREAS=$PIECE(DGRES,U,3)
+10 DO BUILD
End DoDot:1
+11 QUIT
+12 ;
HDR ; Print page header
+1 SET PAGE=$GET(PAGE)+1
+2 WRITE @IOF
WRITE ?15,"Other Than Honorable '",$SELECT(DGRTYP="APPROV":"APPROVED",DGRTYP="PEND":"PENDING",1:"DENIED"),"' Authorizations",?70,"Page: ",PAGE
+3 WRITE !?15,"Selected date range: ",$$FMTE^XLFDT(DGDTFRM,"5Z")," to ",$$FMTE^XLFDT(DGDTTO,"5Z"),!
+4 WRITE "Facility: "_$PIECE(HERE,U,2),?51,"Sorted By: ",$PIECE(DGSORT("REPORT"),U,2),!
+5 FOR DASH=1:1:80
WRITE "-"
+6 IF DGRTYP="APPROV"
Begin DoDot:1
+7 WRITE !,"Name",?23,"PID",?30,"Date Req.",?42,"Date Auth.",?54,"90-Day",?66,"Authorized By"
+8 WRITE !,?30,"Submitted",?42,"Received",?54,"Start DT",!
End DoDot:1
+9 IF DGRTYP="PEND"
WRITE !,"Name",?33,"PID",?41,"Pending Auth.",?58,"# of Days Auth.",!,?41,"Request Date",?58,"is Pending",!
+10 IF DGRTYP="DENIED"
WRITE !,"Name",?24,"PID",?31,"Date Request",?45,"Authorization Comment",!,?31,"Submitted",!
+11 FOR DASH=1:1:80
WRITE "-"
+12 ;
+13 QUIT
+14 ;
PRINT ;Print out results
+1 NEW DGFAC,DGOLDIV,FACILITY,DGPTLIST,DGOEIEN
+2 SET DGOLDIV=""
+3 KILL DGPTLIST
+4 IF '$DATA(@DGRET)
DO HDR
WRITE !!," >>> No records were found using the report criteria.",!
GOTO OUT
+5 IF 2[$PIECE(DGSORT("REPORT"),U)
Begin DoDot:1
+6 DO HDR
+7 SET DGFAC=0
FOR
SET DGFAC=$ORDER(@DGRET@(DGFAC))
if DGFAC=""!(EXIT)
QUIT
DO PRINT1
if EXIT
QUIT
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET DGOEIEN=""
FOR
SET DGOEIEN=$ORDER(DGSORT("DIVISION",DGOEIEN))
if DGOEIEN=""
QUIT
Begin DoDot:2
+10 SET DGFAC=""
FOR
SET DGFAC=$ORDER(DGSORT("DIVISION",DGOEIEN,DGFAC))
if DGFAC=""
QUIT
Begin DoDot:3
+11 DO HDR
DO DVISION
+12 IF '$DATA(@DGRET@(DGFAC))
Begin DoDot:4
+13 WRITE !," >>> No records were found for this Division.",!!
+14 IF ($EXTRACT(IOST,1,2)="C-")&(IO=IO(0))
SET DIR(0)="E"
DO ^DIR
KILL DIR
Begin DoDot:5
+15 IF $DATA(DTOUT)!($DATA(DUOUT))
SET EXIT=1
GOTO OUT
End DoDot:5
End DoDot:4
QUIT
+16 DO PRINT1
End DoDot:3
if EXIT
QUIT
End DoDot:2
if EXIT
QUIT
End DoDot:1
+17 if EXIT
QUIT
+18 IF $EXTRACT(IOST,1,2)="C-"
READ !!?8,"End of the Report...Press Enter to Continue",X:DTIME
WRITE @IOF
+19 QUIT
+20 ;
+21 ;DG*5.3*977 OTH-EXT
DVISION ;
+1 WRITE "Division: ",DGSORT("DIVISION",DGOEIEN,DGFAC)_" ("_DGFAC_")",!
+2 QUIT
+3 ;
PRINT1 ;Print out results
+1 NEW DGOLDNM,SEQ
+2 SET DGOLDNM=""
+3 NEW NAME,DGPER
+4 SET NAME=""
FOR
SET NAME=$ORDER(@DGRET@(DGFAC,NAME))
if NAME=""
QUIT
Begin DoDot:1
+5 IF DGRTYP="APPROV"
Begin DoDot:2
+6 SET DGPER=0
FOR
SET DGPER=$ORDER(@DGRET@(DGFAC,NAME,DGPER))
if DGPER=""
QUIT
Begin DoDot:3
+7 IF $Y+3>IOSL
IF ($EXTRACT(IOST,1,2)="C-")&(IO=IO(0))
SET DIR(0)="E"
DO ^DIR
KILL DIR
Begin DoDot:4
+8 IF $DATA(DTOUT)!($DATA(DUOUT))
SET EXIT=1
GOTO OUT
+9 DO HDR
+10 IF 1[$PIECE(DGSORT("REPORT"),U)
DO DVISION
+11 IF DGOLDNM=NAME
WRITE !,$EXTRACT(NAME,1,22),?23,$PIECE(@DGRET@(DGFAC,NAME,DGPER),U,2)
End DoDot:4
+12 IF 'EXIT
Begin DoDot:4
+13 ;do not display the patient's name twice is sort by facility is selected
+14 IF 2[$PIECE(DGSORT("REPORT"),U)
IF $DATA(DGPTLIST(NAME,DGPER))
QUIT
+15 ;display the patient name and PID once only
+16 IF DGOLDNM'=NAME
WRITE !,$EXTRACT(NAME,1,22),?23,$PIECE(@DGRET@(DGFAC,NAME,DGPER),U,2)
SET DGOLDNM=NAME
+17 WRITE ?30,$PIECE(@DGRET@(DGFAC,NAME,DGPER),U,3),?42,$PIECE(@DGRET@(DGFAC,NAME,DGPER),U,4),?54,$PIECE(@DGRET@(DGFAC,NAME,DGPER),U,5)
+18 WRITE ?66,$EXTRACT($PIECE(@DGRET@(DGFAC,NAME,DGPER),U,6),1,14),!
End DoDot:4
+19 IF 2[$PIECE(DGSORT("REPORT"),U)
IF '$DATA(DGPTLIST(NAME,DGPER))
SET DGPTLIST(NAME,DGPER)=""
End DoDot:3
End DoDot:2
QUIT
+20 IF DGRTYP="PEND"
Begin DoDot:2
+21 IF $Y+3>IOSL
IF ($EXTRACT(IOST,1,2)="C-")&(IO=IO(0))
SET DIR(0)="E"
DO ^DIR
KILL DIR
Begin DoDot:3
+22 IF $DATA(DTOUT)!($DATA(DUOUT))
SET EXIT=1
GOTO OUT
+23 DO HDR
End DoDot:3
+24 IF 'EXIT
Begin DoDot:3
+25 ;do not display the patient's name twice is sort by facility is selected
+26 IF 2[$PIECE(DGSORT("REPORT"),U)
IF $DATA(DGPTLIST(NAME))
QUIT
+27 WRITE !,$EXTRACT(NAME,1,30),?33,$PIECE(@DGRET@(DGFAC,NAME),U,2),?41,$PIECE(@DGRET@(DGFAC,NAME),U,3),?60,$JUSTIFY($PIECE(@DGRET@(DGFAC,NAME),U,4),5)
End DoDot:3
+28 IF 2[$PIECE(DGSORT("REPORT"),U)
IF '$DATA(DGPTLIST(NAME))
SET DGPTLIST(NAME)=""
End DoDot:2
QUIT
+29 IF DGRTYP="DENIED"
Begin DoDot:2
+30 SET SEQ=0
FOR
SET SEQ=$ORDER(@DGRET@(DGFAC,NAME,SEQ))
if SEQ=""
QUIT
Begin DoDot:3
+31 IF $Y+3>IOSL
IF ($EXTRACT(IOST,1,2)="C-")&(IO=IO(0))
SET DIR(0)="E"
DO ^DIR
KILL DIR
Begin DoDot:4
+32 IF $DATA(DTOUT)!($DATA(DUOUT))
SET EXIT=1
GOTO OUT
+33 DO HDR
End DoDot:4
+34 IF 'EXIT
Begin DoDot:4
+35 ;do not display the patient's name twice is sort by facility is selected
+36 IF 2[$PIECE(DGSORT("REPORT"),U)
IF $DATA(DGPTLIST(NAME,SEQ))
QUIT
+37 ;display the patient name and PID once only
+38 IF DGOLDNM'=NAME
WRITE !,$EXTRACT(NAME,1,22),?24,$PIECE(@DGRET@(DGFAC,NAME,SEQ),U,2)
SET DGOLDNM=NAME
+39 WRITE ?31,$PIECE(@DGRET@(DGFAC,NAME,SEQ),U,3),?45,$EXTRACT($PIECE(@DGRET@(DGFAC,NAME,SEQ),U,4),1,35),!
End DoDot:4
+40 IF 2[$PIECE(DGSORT("REPORT"),U)
IF '$DATA(DGPTLIST(NAME))
SET DGPTLIST(NAME,SEQ)=""
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+41 if EXIT
QUIT
+42 IF 1[$PIECE(DGSORT("REPORT"),U)
IF ($EXTRACT(IOST,1,2)="C-")&(IO=IO(0))
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
Begin DoDot:1
+43 IF $DATA(DTOUT)!($DATA(DUOUT))
SET EXIT=1
GOTO OUT
WRITE !
End DoDot:1
+44 QUIT
+45 ;
DTFRMTO(PROMPT) ;Get from and to dates
+1 NEW %DT,Y,X,DTOUT,OUT,DIRUT,DUOUT,DIROUT,STATUS,STDT,STATUS
+2 ;INPUT ; PROMPT - Message to display prior to prompting for dates
+3 ;OUTPUT: 1^BEGDT^ENDDT - Data found
+4 ; 0 - User up arrowed or timed out
+5 ;If they want to show first available date for that set of Status, use this sub
INDT ;
+1 SET OUT=0
+2 SET DIR(0)="DO^"_DT_":"_DT_":EX"
+3 ;Enter Beginning Date: "
SET %DT="AEX"
SET %DT("A")="Starting date - From: "
+4 WRITE !
DO ^%DT
KILL %DT
+5 ;Quit if user time out or didn't enter valid date
IF Y<0
WRITE !!,"No Date selected, quitting. ",!!
QUIT OUT
+6 ;Future dates not allowed
IF Y>DT
WRITE !!,"Future dates are not allowed, please re-enter"
KILL Y,%DT
GOTO INDT
+7 SET DGDTFRM=+Y
TODT ; Get end date, default is "TODAY"
SET %DT="AEX"
SET %DT("A")=" Ending date - TO: "
SET %DT("B")="T"
+1 DO ^%DT
KILL %DT
+2 ;Quit if user time out or didn't enter valid date
+3 IF Y<0
WRITE !!,"No Date selected, quitting. ",!!
QUIT OUT
+4 IF Y<DGDTFRM
WRITE !!,"Ending date must be greater than or equal to the start date",!!
KILL Y,%DT
GOTO TODT
+5 SET DGDTTO=+Y
SET OUT=1_U_DGDTFRM_U_DGDTTO
+6 ;Switch dates if Begin Date is more recent than End Date
+7 if DGDTFRM>DGDTTO
SET OUT=1_U_DGDTTO_U_DGDTFRM
+8 QUIT OUT
+9 ;
SELECT(PROMPT,SET) ; prompts for a report type
+1 ;INPUT:
+2 SET DIR(0)=SET
SET DIR("A")=PROMPT
SET DIR("B")=1
SET DIR("?")="^D HELP^DGOTHRP5(1)"
SET DIR("??")=DIR("?")
DO ^DIR
KILL DIR
+3 if Y<0
QUIT OUT
+4 QUIT Y
+5 ;
OUT ; KILL RETURN ARRAY QUIT
+1 DO ^%ZISC
+2 KILL @DGRET
+3 QUIT
+4 ;
+5 ;DG*5.3*977 OTH-EXT
HELP(DGSEL) ;OTH-90 Authorization Report help text
+1 IF DGSEL=1
Begin DoDot:1
+2 WRITE !," Please ENTER:",!
+3 DO TEXT
+4 WRITE !," 1 = That have been 'APPROVED' for an additional 90-Day"
+5 WRITE !," period of care."
+6 WRITE !," 2 = Whose request for an additional 90-Day period of"
+7 WRITE !," care is waiting to be approved or denied."
+8 WRITE !," 3 = Whose request for an additional 90-Day period of"
+9 WRITE !," care has been DENIED."
End DoDot:1
+10 QUIT
+11 ;
+12 ;DG*5.3*977 OTH-EXT
TEXT ;
+1 WRITE !," If you wish to print a list(s) of OTH-90 MH Care"
+2 WRITE !," patient who have an Outpatient Encounter with"
+3 WRITE !," STATUS=CHECKED OUT for selected Division within"
+4 WRITE !," the user-specified date range.",!
+5 QUIT
+6 ;
