- 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 Jan 18, 2025@03:47:44 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