DGOTHRP6 ;SLC/RED(LIB) - OTHD (OTHER THAN HONORABLE DISCHARGE) Reports ;May 9,2018@05:08
;;5.3;Registration;**952,977**;May 9, 2018;Build 177
;;Per VA Directive 6402, this routine should not be modified.
;
; Last Edited: SHRPE/RED - June 14, 2019 09:00
;
; IA: 10103 ^XLFDT (sup) - [$$FMADD^XLFDT, $$FMTE^XLFDT , $$NOW^XLFDT]
; 10112 $$SITE^VASITE
; 10015 ^DIQ (sup)
; 10026 ^DIR (sup)
; 10061 PID^VADPT (sup)
; 10063 ^%ZTLOAD (sup)
; 10089 ^%ZISC (sup)
;
Q ;Cannot be ran directly
;
;Prepares a list of patients registered in VistA since Executive Order 13822 was released (Jan. 9, 2018) who
; have an "other than honorable" discharge type and are not enrolled in VA healthcare. "
;
; Special Note: This report excludes patients with Patient Enrollment status of 'VERIFIED', I'm not completely sure this is a valid screen.
;
EN ; VistA option: DG OTH POTENTIAL OTH PTS
N DGSTDT,MINDTE,MAXDTE,MINDTE,MAXDTE
W @IOF
S MINDT=3100701,MAXDT=DT
S DGSTDT=$$STARTDT(MINDT,MAXDT)
I DGSTDT=0 Q
; Allow queueing
K IOP,IO("Q") S %ZIS="MQ",%ZIS("B")="",POP=0 D ^%ZIS
Q:POP
I $D(IO("Q")) D Q ;Queued report settings
.S ZTDESC="Potential OTH Patients Report",ZTRTN="ENQUE^DGOTHRP6"
.S ZTSAVE("DGSTDT")="",ZTSAVE("ZTREQ")="@"
.D ^%ZTLOAD,HOME^%ZIS
.I $G(ZTSK) W !!,"Report compilation has started with task# ",ZTSK,".",!
I $E(IOST)="C" D WAIT^DICD
;
ENQUE ; Queued entry
N DFN,DGENR,DGENR,DGSTAT,DGENDT,DGELIG,DGARRAY,PAGE,COUNT,DGDOD,DASH,DESCR,DGDISC,DGLAST,DGNAME,DGQ,PID,EXIT
S DGARRAY=$NA(^TMP("DGOTHRP6",$J)) K @DGARRAY
S PAGE=1,COUNT=0
I $G(DGSTDT)="" S DGSTDT=3170701 ;Default start date
S DFN="+" F S DFN=$O(^DPT(DFN),-1) Q:DFN<1 D
. S DGENDT=$P($G(^DPT(DFN,0)),U,16) ;Date entry added to VistA
. I DGENDT<DGSTDT Q ;Vista Entry was made before the start date, not need to keep looking
. S DGLAST=$O(^DPT(DFN,.3216,99999),-1) ;Get the latest period of service
. S DGDISC=$$GET1^DIQ(2.3216,DGLAST_","_DFN_",",".06","I")
. Q:DGDISC'=4 ;Character of discharge is not OTH
. Q:$D(^DGOTH(33,"B",DFN)) ;Exists as an OTH patient in file #33
. S DGENR=$O(^DGEN(27.11,"C",DFN,99999999),-1)
. I DGENR S DGSTAT=$$GET1^DIQ(27.11,DGENR_",",".04")
. Q:$G(DGSTAT)="VERIFIED"
. S DGDOD=$P($$GET1^DIQ(2,DFN_",",".351","I"),".")
. D DEM^VADPT ;get patient demographics
. S DGNAME=VADM(1),PID=$E(DGNAME,1)_$P($P(VADM(2),U,2),"-",3) D KVA^VADPT
. S DGELIG=$$GET1^DIQ(2,DFN_",",".361") ;Current Primary Eligibility
. S @DGARRAY@(DGNAME)=PID_U_DGENDT_U_DGDOD_U_DGELIG,COUNT=COUNT+1
D PRTHDR,PRNTREP,QUIT
Q
;
PRTHDR ;
I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQ)=1 Q
W @IOF
I PAGE=1 D
. W "This report will list patients registered in VistA since Executive"
. W !,"Order #13822 (dated Jan. 9, 2018) who have an 'Other Than Honorable'"
. W !,"discharge type and are not currently enrolled in VA healthcare."
. W !!,"The default start date is 7/1/17, you may select a different start date"
. W !?3,"REPORT RUN DATE: ",$$FMTE^XLFDT(DT,10),?40,"STARTING DATE RANGE: ",$$FMTE^XLFDT(DGSTDT,10),!
F DASH=1:1:75 W "="
W !,"PATIENTS WITH 'OTH' DISCHARGE TYPE",?37,"FACILITY: ",$E($P($$SITE^VASITE,U,2),1,19),?68,"PAGE: ",PAGE,!
F DASH=1:1:75 W "="
W !,"PATIENT",?22,"PID",?30,"REG. DATE",?41,"CURRENT PRIMARY ELIG.",?65,"DATE OF",!,?65,"DEATH",!
F DASH=1:1:75 W "-"
Q
;
PRNTREP ;Print the report
N NAM
I '$D(@DGARRAY) D Q
.W !!," >>> No records were found using the report criteria.",!
.D ASKCONT^DGOTHMG2
.Q
S NAM="",EXIT=0
F S NAM=$O(@DGARRAY@(NAM)) Q:NAM="" D Q:EXIT
.I ($E(IOST,1,2)="C-"),$Y+3>IOSL S DIR(0)="E" D ^DIR K DIR D
. . I $D(DTOUT)!($D(DUOUT)) S EXIT=1 G QUIT
. . S PAGE=PAGE+1 D PRTHDR
. Q:EXIT
. W !,$E(NAM,1,20),?22,$P(@DGARRAY@(NAM),U),?30,$$FMTE^XLFDT($P(@DGARRAY@(NAM),U,2),5),?41,$E($P(@DGARRAY@(NAM),U,4),1,23),?65,$$FMTE^XLFDT($P(@DGARRAY@(NAM),U,3),5)
W:'EXIT !!,"Total number of Patients: ",COUNT
I $E(IOST,1,2)="C-",'EXIT R !!?8,"End of the Report...Press Enter to Continue",X:DTIME W @IOF
Q
;
STARTDT(MINDT,MAXDT) ;
S DESCR=""
; MINDT = earliest allowed date (required)
; returns date in internal FM format or 0 on user exit
;
N DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
; get min and max dates in external format
S MINDTE=$$FMTE^XLFDT(3170701),MAXDTE=$$FMTE^XLFDT(MAXDT)
S DIR(0)="DA^"_MINDT_":"_MAXDT_":EX"
S DIR("A")="Search start date: "
S DIR("B")=$$FMTE^XLFDT(3170701)
S DIR("?")="Latest allowed date is TODAY"
S DIR("?",1)="Earliest allowed date is "_MINDTE_"."
D ^DIR
I $D(DTOUT)!$D(DUOUT) Q 0
Q +Y
;
QUIT ;
K @DGARRAY
Q
;
;END DGOTHRP6
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGOTHRP6 5012 printed Sep 23, 2025@20:22:55 Page 2
DGOTHRP6 ;SLC/RED(LIB) - OTHD (OTHER THAN HONORABLE DISCHARGE) Reports ;May 9,2018@05:08
+1 ;;5.3;Registration;**952,977**;May 9, 2018;Build 177
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Last Edited: SHRPE/RED - June 14, 2019 09:00
+5 ;
+6 ; IA: 10103 ^XLFDT (sup) - [$$FMADD^XLFDT, $$FMTE^XLFDT , $$NOW^XLFDT]
+7 ; 10112 $$SITE^VASITE
+8 ; 10015 ^DIQ (sup)
+9 ; 10026 ^DIR (sup)
+10 ; 10061 PID^VADPT (sup)
+11 ; 10063 ^%ZTLOAD (sup)
+12 ; 10089 ^%ZISC (sup)
+13 ;
+14 ;Cannot be ran directly
QUIT
+15 ;
+16 ;Prepares a list of patients registered in VistA since Executive Order 13822 was released (Jan. 9, 2018) who
+17 ; have an "other than honorable" discharge type and are not enrolled in VA healthcare. "
+18 ;
+19 ; Special Note: This report excludes patients with Patient Enrollment status of 'VERIFIED', I'm not completely sure this is a valid screen.
+20 ;
EN ; VistA option: DG OTH POTENTIAL OTH PTS
+1 NEW DGSTDT,MINDTE,MAXDTE,MINDTE,MAXDTE
+2 WRITE @IOF
+3 SET MINDT=3100701
SET MAXDT=DT
+4 SET DGSTDT=$$STARTDT(MINDT,MAXDT)
+5 IF DGSTDT=0
QUIT
+6 ; Allow queueing
+7 KILL IOP,IO("Q")
SET %ZIS="MQ"
SET %ZIS("B")=""
SET POP=0
DO ^%ZIS
+8 if POP
QUIT
+9 ;Queued report settings
IF $DATA(IO("Q"))
Begin DoDot:1
+10 SET ZTDESC="Potential OTH Patients Report"
SET ZTRTN="ENQUE^DGOTHRP6"
+11 SET ZTSAVE("DGSTDT")=""
SET ZTSAVE("ZTREQ")="@"
+12 DO ^%ZTLOAD
DO HOME^%ZIS
+13 IF $GET(ZTSK)
WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
End DoDot:1
QUIT
+14 IF $EXTRACT(IOST)="C"
DO WAIT^DICD
+15 ;
ENQUE ; Queued entry
+1 NEW DFN,DGENR,DGENR,DGSTAT,DGENDT,DGELIG,DGARRAY,PAGE,COUNT,DGDOD,DASH,DESCR,DGDISC,DGLAST,DGNAME,DGQ,PID,EXIT
+2 SET DGARRAY=$NAME(^TMP("DGOTHRP6",$JOB))
KILL @DGARRAY
+3 SET PAGE=1
SET COUNT=0
+4 ;Default start date
IF $GET(DGSTDT)=""
SET DGSTDT=3170701
+5 SET DFN="+"
FOR
SET DFN=$ORDER(^DPT(DFN),-1)
if DFN<1
QUIT
Begin DoDot:1
+6 ;Date entry added to VistA
SET DGENDT=$PIECE($GET(^DPT(DFN,0)),U,16)
+7 ;Vista Entry was made before the start date, not need to keep looking
IF DGENDT<DGSTDT
QUIT
+8 ;Get the latest period of service
SET DGLAST=$ORDER(^DPT(DFN,.3216,99999),-1)
+9 SET DGDISC=$$GET1^DIQ(2.3216,DGLAST_","_DFN_",",".06","I")
+10 ;Character of discharge is not OTH
if DGDISC'=4
QUIT
+11 ;Exists as an OTH patient in file #33
if $DATA(^DGOTH(33,"B",DFN))
QUIT
+12 SET DGENR=$ORDER(^DGEN(27.11,"C",DFN,99999999),-1)
+13 IF DGENR
SET DGSTAT=$$GET1^DIQ(27.11,DGENR_",",".04")
+14 if $GET(DGSTAT)="VERIFIED"
QUIT
+15 SET DGDOD=$PIECE($$GET1^DIQ(2,DFN_",",".351","I"),".")
+16 ;get patient demographics
DO DEM^VADPT
+17 SET DGNAME=VADM(1)
SET PID=$EXTRACT(DGNAME,1)_$PIECE($PIECE(VADM(2),U,2),"-",3)
DO KVA^VADPT
+18 ;Current Primary Eligibility
SET DGELIG=$$GET1^DIQ(2,DFN_",",".361")
+19 SET @DGARRAY@(DGNAME)=PID_U_DGENDT_U_DGDOD_U_DGELIG
SET COUNT=COUNT+1
End DoDot:1
+20 DO PRTHDR
DO PRNTREP
DO QUIT
+21 QUIT
+22 ;
PRTHDR ;
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,DGQ)=1
QUIT
+2 WRITE @IOF
+3 IF PAGE=1
Begin DoDot:1
+4 WRITE "This report will list patients registered in VistA since Executive"
+5 WRITE !,"Order #13822 (dated Jan. 9, 2018) who have an 'Other Than Honorable'"
+6 WRITE !,"discharge type and are not currently enrolled in VA healthcare."
+7 WRITE !!,"The default start date is 7/1/17, you may select a different start date"
+8 WRITE !?3,"REPORT RUN DATE: ",$$FMTE^XLFDT(DT,10),?40,"STARTING DATE RANGE: ",$$FMTE^XLFDT(DGSTDT,10),!
End DoDot:1
+9 FOR DASH=1:1:75
WRITE "="
+10 WRITE !,"PATIENTS WITH 'OTH' DISCHARGE TYPE",?37,"FACILITY: ",$EXTRACT($PIECE($$SITE^VASITE,U,2),1,19),?68,"PAGE: ",PAGE,!
+11 FOR DASH=1:1:75
WRITE "="
+12 WRITE !,"PATIENT",?22,"PID",?30,"REG. DATE",?41,"CURRENT PRIMARY ELIG.",?65,"DATE OF",!,?65,"DEATH",!
+13 FOR DASH=1:1:75
WRITE "-"
+14 QUIT
+15 ;
PRNTREP ;Print the report
+1 NEW NAM
+2 IF '$DATA(@DGARRAY)
Begin DoDot:1
+3 WRITE !!," >>> No records were found using the report criteria.",!
+4 DO ASKCONT^DGOTHMG2
+5 QUIT
End DoDot:1
QUIT
+6 SET NAM=""
SET EXIT=0
+7 FOR
SET NAM=$ORDER(@DGARRAY@(NAM))
if NAM=""
QUIT
Begin DoDot:1
+8 IF ($EXTRACT(IOST,1,2)="C-")
IF $Y+3>IOSL
SET DIR(0)="E"
DO ^DIR
KILL DIR
Begin DoDot:2
+9 IF $DATA(DTOUT)!($DATA(DUOUT))
SET EXIT=1
GOTO QUIT
+10 SET PAGE=PAGE+1
DO PRTHDR
End DoDot:2
+11 if EXIT
QUIT
+12 WRITE !,$EXTRACT(NAM,1,20),?22,$PIECE(@DGARRAY@(NAM),U),?30,$$FMTE^XLFDT($PIECE(@DGARRAY@(NAM),U,2),5),?41,$EXTRACT($PIECE(@DGARRAY@(NAM),U,4),1,23),?65,$$FMTE^XLFDT($PIECE(@DGARRAY@(NAM),U,3),5)
End DoDot:1
if EXIT
QUIT
+13 if 'EXIT
WRITE !!,"Total number of Patients: ",COUNT
+14 IF $EXTRACT(IOST,1,2)="C-"
IF 'EXIT
READ !!?8,"End of the Report...Press Enter to Continue",X:DTIME
WRITE @IOF
+15 QUIT
+16 ;
STARTDT(MINDT,MAXDT) ;
+1 SET DESCR=""
+2 ; MINDT = earliest allowed date (required)
+3 ; returns date in internal FM format or 0 on user exit
+4 ;
+5 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
+6 ; get min and max dates in external format
+7 SET MINDTE=$$FMTE^XLFDT(3170701)
SET MAXDTE=$$FMTE^XLFDT(MAXDT)
+8 SET DIR(0)="DA^"_MINDT_":"_MAXDT_":EX"
+9 SET DIR("A")="Search start date: "
+10 SET DIR("B")=$$FMTE^XLFDT(3170701)
+11 SET DIR("?")="Latest allowed date is TODAY"
+12 SET DIR("?",1)="Earliest allowed date is "_MINDTE_"."
+13 DO ^DIR
+14 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT 0
+15 QUIT +Y
+16 ;
QUIT ;
+1 KILL @DGARRAY
+2 QUIT
+3 ;
+4 ;END DGOTHRP6
