DGCV1 ;ALB/ERC,BRM - COMBAT VET REPORTS; 07/10/2003 ; 2/5/04 2:52pm
;;5.3;Registration;**528,565**; Aug 13, 1993
;
;first report is built during the initial seeding, and called by
;POST^DG53528P
RPT(DG) ;if, during initial seeding, a veteran could not be evaluated
;for CV eligibility because of an imprecise date the veteran will be
;added to the appropriate ^XTMP global
; Input: DG - the code corresponding to the missing or imprecise date
;
K VADM
I $G(DG)']"" Q
S ^XTMP("DGCV","REPORT",DFN,DG)=""
Q
REPORT ;if there are veterans in the ^XTMP globals, create a report.
I '$D(^XTMP("DGCV","REPORT")) Q
N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZUSR,POP,X,ERR
K IOP,%ZIS
I $G(XPDQUES("POS1","B"))]"" S ZTIO=$G(XPDQUES("POS1","B")) ;result of install question
I $G(ZTIO)']"" S IOP=$G(^XTMP("DGCV","DEVICE"))
S ZTSAVE("*")=""
S ZTRTN="PRINT^DGCV1",ZTDESC="IMPRECISE COMBAT DATE REPORT"
D ^%ZTLOAD
EXIT ;
K XPDQUES
Q
PRINT ;print report
N PAGE,QUIT,DFN
S PAGE=1
S QUIT=""
D HDR
N DGF,DGFD,DGLN,DGNAM,DGSSN
S (DGF,DFN)=""
F S DFN=$O(^XTMP("DGCV","REPORT",DFN)) Q:DFN']"" D
. Q:'$D(^DPT(DFN))
. S (DGNAM,DGSSN)=""
. D DEM(DFN)
. I $G(DGNAM)']""!($G(DGSSN)']"") Q
. S DGLN=DGNAM_"^"_DGSSN
. N DGC
. F S DGF=$O(^XTMP("DGCV","REPORT",DFN,DGF)) Q:DGF']""!(QUIT) D
. . N DGFF
. . I $L(DGF)=1 S DGFF=DGF S DGC=1 D SET
. . I $L(DGF)=2 D
. . . S DGFF=$E(DGF,1),DGC=1 D SET
. . . S DGFF=$E(DGF,2),DGC=2 D SET
W !,">>>>END OF REPORT"
Q
SET ;
I DGFF["A"!(DGFF["F") S DGFD="SERVICE SEP"
I DGFF["B"!(DGFF["G") S DGFD="COMBAT TO"
I DGFF["C"!(DGFF["H") S DGFD="YUGOSLAVIA TO"
I DGFF["D"!(DGFF["I") S DGFD="SOMALIA TO"
I DGFF["E"!(DGFF["J") S DGFD="PERS GULF TO"
I $G(DGFD)']"" Q
S DGFD=DGFD_" DATE "_$S("ABCDE"[DGFF:"IMPRECISE",1:"MISSING")
S DGLN=$S(DGC=1:DGLN_"^"_DGFD,DGC=2:"^^"_DGFD,1:"")
D ADD(DGLN)
Q
DEM(DFN) ;
N VADM
D DEM^VADPT
S DGNAM=$G(VADM(1))
S DGSSN=$P($G(VADM(2)),U,2)
Q
ADD(DGLN) ;add the line to the report
N DGX
I $P(DGLN,U)]"" W !
W !?2,$P(DGLN,U),?39,$P(DGLN,U,2),?52,$P(DGLN,U,3)
I $E(IOST,1,2)="C-",($Y>(IOSL-4)) D
. D PAUSE
. Q:QUIT
. D TOP
I '$E(IOST,1,2)="C-",($Y>(IOSL-2)) D TOP
Q
;
TOP ;
W @IOF
D HDR
Q
;
HDR ;print header for report
N Y
W !!?5,"REPORT OF UPDATES REQUIRED FOR COMBAT VET STATUS" S Y=DT D DD^%DT W ?62,"Date: ",Y
W !,?62,"Page: ",PAGE
W !!?5,"The following patients could not be evaluated for Combat Veteran"
W !?5,"Eligibility status due to having imprecise or missing dates."
W !!!?2,"Patient Name",?39,"SSN",?52,"Date to be updated"
W !?2,"===================================",?39,"===========",?52,"=========================="
S PAGE=PAGE+1
Q
;
RPT2 ;second report is option DG CV STATUS, a report of what veterans were
;assigned CV status during a specified date range
N DIR,DIRUT,X1,X2,X,Y,DGBEG,DGDT,DGEND
S DIR(0)="DAO^,"_DT
S X1=DT,X2=-7 D C^%DTC
S Y=X D DD^%DT
S DIR("A")="BEGINNING DATE: "
S DIR("B")=Y
S DIR("?")="ENTER THE BEGINNING DATE FOR THE REPORT"
S DIR("??")="^W !,""A BEGINNING AND AN END DATE MUST BE ENTERED FOR THIS REPORT"""
D ^DIR
Q:$D(DIRUT)
S DGBEG=Y
S DIR(0)="DAO^"_DGBEG_","_DT
S Y=DT D DD^%DT S DGDT=Y
S DIR("B")=DGDT
S DIR("A")="ENDING DATE: "
S DIR("?")="ENTER THE ENDING DATE FOR THE REPORT"
D ^DIR
Q:$D(DIRUT)
S DGEND=Y
D REPORT2(DGBEG,DGEND)
Q
;
REPORT2(DGBEG,DGEND) ;
I $G(DGBEG)']""!($G(DGEND)']"") W !!,"DATE RANGE NOT SET. EXITING" Q
N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZUSR,POP,X,ERR
K IOP,%ZIS
S %ZIS="Q" D ^%ZIS G:POP EXIT2
I $D(IO("Q")) D Q
. S (ZTSAVE("DGBEG"),ZTSAVE("DGEND"))=""
. S ZTRTN="PRINT2^DGCV1",ZTDESC="COMBAT VET DATE EDITED REPORT"
. D ^%ZTLOAD
. D ^%ZISC,HOME^%ZIS
. W !,$S($D(ZTSK):"REQUEST QUEUED!",1:"REQUEST CANCELLED!")
D PRINT2
EXIT2 D ^%ZISC,HOME^%ZIS
;Q +G(ZTSK)
Q
PRINT2 ;
N DGLN,PAGE,QUIT
S QUIT=""
U IO
I $E(IOST,1,2)="C-" W @IOF
S DGLN=0
S PAGE=1
D HDR2
D DATA
I DGLN=0 D
. W !!!,?30,"No data to report."
. I $E(IOST,1,2)="C-" D PAUSE
D EXIT2
Q
HDR2 ;
N DG1,DG2,Y
S Y=DGBEG D DD^%DT S DG1=Y
S Y=DGEND D DD^%DT S DG2=Y
W !!?15,"COMBAT VETERAN STATUS CHANGED REPORT"
S Y=DT D DD^%DT W ?60,"Date: ",Y
W !?20,DG1_" TO "_DG2
W ?60,"Page: "_PAGE
W !!!?3,"NAME",?41,"SSN",?63,"CV END DATE",!?41,"PRIORITY GROUP"
W !,?3,"===================================",?41,"=================",?63,"============"
S PAGE=PAGE+1
Q
DATA ;
N DGENR,DFN,DGNAM,DGSSN,DGDT,DGX,QUIT,Y,VADM
S QUIT=""
Q:$G(DGBEG)']""!($G(DGEND)']"")
S DGX=DGBEG-1
F S DGX=$O(^DPT("E",DGX)) Q:DGX'>0!(DGX>DGEND) D
. S DFN=""
. F S DFN=$O(^DPT("E",DGX,DFN)) Q:DFN']""!(QUIT) D
. . Q:'$D(^DPT(DFN))
. . K VADM,DGENR
. . D DEM^VADPT
. . Q:'$D(VADM)
. . S DGNAM=VADM(1)
. . S DGSSN=$P(VADM(2),U,2)
. . S DGDT=$$GET1^DIQ(2,DFN_",",.5295,"E")
. . I $G(DGDT)']"" S DGDT="DELETED!!!!"
. . S DGENR=$$PRIOR(DFN)
. . I $G(DGENR)']"" S DGENR="NONE"
. . D ADD2
Q
PRIOR(DFN) ;gets priority and sub group
;
N DGEN,DGIEN,DGSUB
I $$GET^DGENA($$FINDCUR^DGENA(DFN),.DGEN) D
. S DGENR=$G(DGEN("PRIORITY"))
. S DGSUB=$G(DGEN("SUBGRP"))
. I $G(DGSUB)]"" S DGENR=DGENR_$$EXTERNAL^DILFD(27.11,.12,"F",DGSUB)
Q $G(DGENR)
PAUSE ;
N DIR,DIRUT,X,Y
F Q:$Y>(IOSL-3) W !
S DIR(0)="E"
D ^DIR
I ('(+Y))!($D(DIRUT)) S QUIT=1
Q
ADD2 ;
I $E(IOST,1,2)="C-",($Y>(IOSL-6)) D
. D PAUSE
. Q:QUIT
. D TOP2
I '$E(IOST,1,2)="C-",($Y>(IOSL-2)) D TOP2
I '(QUIT) D LINE
Q
TOP2 ;
W @IOF
D HDR2
Q
LINE ;add a line to the report
W !?3,DGNAM,?41,DGSSN,?63,DGDT,!?41,DGENR,!
S DGLN=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGCV1 5678 printed Dec 13, 2024@02:41:47 Page 2
DGCV1 ;ALB/ERC,BRM - COMBAT VET REPORTS; 07/10/2003 ; 2/5/04 2:52pm
+1 ;;5.3;Registration;**528,565**; Aug 13, 1993
+2 ;
+3 ;first report is built during the initial seeding, and called by
+4 ;POST^DG53528P
RPT(DG) ;if, during initial seeding, a veteran could not be evaluated
+1 ;for CV eligibility because of an imprecise date the veteran will be
+2 ;added to the appropriate ^XTMP global
+3 ; Input: DG - the code corresponding to the missing or imprecise date
+4 ;
+5 KILL VADM
+6 IF $GET(DG)']""
QUIT
+7 SET ^XTMP("DGCV","REPORT",DFN,DG)=""
+8 QUIT
REPORT ;if there are veterans in the ^XTMP globals, create a report.
+1 IF '$DATA(^XTMP("DGCV","REPORT"))
QUIT
+2 NEW ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZUSR,POP,X,ERR
+3 KILL IOP,%ZIS
+4 ;result of install question
IF $GET(XPDQUES("POS1","B"))]""
SET ZTIO=$GET(XPDQUES("POS1","B"))
+5 IF $GET(ZTIO)']""
SET IOP=$GET(^XTMP("DGCV","DEVICE"))
+6 SET ZTSAVE("*")=""
+7 SET ZTRTN="PRINT^DGCV1"
SET ZTDESC="IMPRECISE COMBAT DATE REPORT"
+8 DO ^%ZTLOAD
EXIT ;
+1 KILL XPDQUES
+2 QUIT
PRINT ;print report
+1 NEW PAGE,QUIT,DFN
+2 SET PAGE=1
+3 SET QUIT=""
+4 DO HDR
+5 NEW DGF,DGFD,DGLN,DGNAM,DGSSN
+6 SET (DGF,DFN)=""
+7 FOR
SET DFN=$ORDER(^XTMP("DGCV","REPORT",DFN))
if DFN']""
QUIT
Begin DoDot:1
+8 if '$DATA(^DPT(DFN))
QUIT
+9 SET (DGNAM,DGSSN)=""
+10 DO DEM(DFN)
+11 IF $GET(DGNAM)']""!($GET(DGSSN)']"")
QUIT
+12 SET DGLN=DGNAM_"^"_DGSSN
+13 NEW DGC
+14 FOR
SET DGF=$ORDER(^XTMP("DGCV","REPORT",DFN,DGF))
if DGF']""!(QUIT)
QUIT
Begin DoDot:2
+15 NEW DGFF
+16 IF $LENGTH(DGF)=1
SET DGFF=DGF
SET DGC=1
DO SET
+17 IF $LENGTH(DGF)=2
Begin DoDot:3
+18 SET DGFF=$EXTRACT(DGF,1)
SET DGC=1
DO SET
+19 SET DGFF=$EXTRACT(DGF,2)
SET DGC=2
DO SET
End DoDot:3
End DoDot:2
End DoDot:1
+20 WRITE !,">>>>END OF REPORT"
+21 QUIT
SET ;
+1 IF DGFF["A"!(DGFF["F")
SET DGFD="SERVICE SEP"
+2 IF DGFF["B"!(DGFF["G")
SET DGFD="COMBAT TO"
+3 IF DGFF["C"!(DGFF["H")
SET DGFD="YUGOSLAVIA TO"
+4 IF DGFF["D"!(DGFF["I")
SET DGFD="SOMALIA TO"
+5 IF DGFF["E"!(DGFF["J")
SET DGFD="PERS GULF TO"
+6 IF $GET(DGFD)']""
QUIT
+7 SET DGFD=DGFD_" DATE "_$SELECT("ABCDE"[DGFF:"IMPRECISE",1:"MISSING")
+8 SET DGLN=$SELECT(DGC=1:DGLN_"^"_DGFD,DGC=2:"^^"_DGFD,1:"")
+9 DO ADD(DGLN)
+10 QUIT
DEM(DFN) ;
+1 NEW VADM
+2 DO DEM^VADPT
+3 SET DGNAM=$GET(VADM(1))
+4 SET DGSSN=$PIECE($GET(VADM(2)),U,2)
+5 QUIT
ADD(DGLN) ;add the line to the report
+1 NEW DGX
+2 IF $PIECE(DGLN,U)]""
WRITE !
+3 WRITE !?2,$PIECE(DGLN,U),?39,$PIECE(DGLN,U,2),?52,$PIECE(DGLN,U,3)
+4 IF $EXTRACT(IOST,1,2)="C-"
IF ($Y>(IOSL-4))
Begin DoDot:1
+5 DO PAUSE
+6 if QUIT
QUIT
+7 DO TOP
End DoDot:1
+8 IF '$EXTRACT(IOST,1,2)="C-"
IF ($Y>(IOSL-2))
DO TOP
+9 QUIT
+10 ;
TOP ;
+1 WRITE @IOF
+2 DO HDR
+3 QUIT
+4 ;
HDR ;print header for report
+1 NEW Y
+2 WRITE !!?5,"REPORT OF UPDATES REQUIRED FOR COMBAT VET STATUS"
SET Y=DT
DO DD^%DT
WRITE ?62,"Date: ",Y
+3 WRITE !,?62,"Page: ",PAGE
+4 WRITE !!?5,"The following patients could not be evaluated for Combat Veteran"
+5 WRITE !?5,"Eligibility status due to having imprecise or missing dates."
+6 WRITE !!!?2,"Patient Name",?39,"SSN",?52,"Date to be updated"
+7 WRITE !?2,"===================================",?39,"===========",?52,"=========================="
+8 SET PAGE=PAGE+1
+9 QUIT
+10 ;
RPT2 ;second report is option DG CV STATUS, a report of what veterans were
+1 ;assigned CV status during a specified date range
+2 NEW DIR,DIRUT,X1,X2,X,Y,DGBEG,DGDT,DGEND
+3 SET DIR(0)="DAO^,"_DT
+4 SET X1=DT
SET X2=-7
DO C^%DTC
+5 SET Y=X
DO DD^%DT
+6 SET DIR("A")="BEGINNING DATE: "
+7 SET DIR("B")=Y
+8 SET DIR("?")="ENTER THE BEGINNING DATE FOR THE REPORT"
+9 SET DIR("??")="^W !,""A BEGINNING AND AN END DATE MUST BE ENTERED FOR THIS REPORT"""
+10 DO ^DIR
+11 if $DATA(DIRUT)
QUIT
+12 SET DGBEG=Y
+13 SET DIR(0)="DAO^"_DGBEG_","_DT
+14 SET Y=DT
DO DD^%DT
SET DGDT=Y
+15 SET DIR("B")=DGDT
+16 SET DIR("A")="ENDING DATE: "
+17 SET DIR("?")="ENTER THE ENDING DATE FOR THE REPORT"
+18 DO ^DIR
+19 if $DATA(DIRUT)
QUIT
+20 SET DGEND=Y
+21 DO REPORT2(DGBEG,DGEND)
+22 QUIT
+23 ;
REPORT2(DGBEG,DGEND) ;
+1 IF $GET(DGBEG)']""!($GET(DGEND)']"")
WRITE !!,"DATE RANGE NOT SET. EXITING"
QUIT
+2 NEW ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZUSR,POP,X,ERR
+3 KILL IOP,%ZIS
+4 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EXIT2
+5 IF $DATA(IO("Q"))
Begin DoDot:1
+6 SET (ZTSAVE("DGBEG"),ZTSAVE("DGEND"))=""
+7 SET ZTRTN="PRINT2^DGCV1"
SET ZTDESC="COMBAT VET DATE EDITED REPORT"
+8 DO ^%ZTLOAD
+9 DO ^%ZISC
DO HOME^%ZIS
+10 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED!",1:"REQUEST CANCELLED!")
End DoDot:1
QUIT
+11 DO PRINT2
EXIT2 DO ^%ZISC
DO HOME^%ZIS
+1 ;Q +G(ZTSK)
+2 QUIT
PRINT2 ;
+1 NEW DGLN,PAGE,QUIT
+2 SET QUIT=""
+3 USE IO
+4 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+5 SET DGLN=0
+6 SET PAGE=1
+7 DO HDR2
+8 DO DATA
+9 IF DGLN=0
Begin DoDot:1
+10 WRITE !!!,?30,"No data to report."
+11 IF $EXTRACT(IOST,1,2)="C-"
DO PAUSE
End DoDot:1
+12 DO EXIT2
+13 QUIT
HDR2 ;
+1 NEW DG1,DG2,Y
+2 SET Y=DGBEG
DO DD^%DT
SET DG1=Y
+3 SET Y=DGEND
DO DD^%DT
SET DG2=Y
+4 WRITE !!?15,"COMBAT VETERAN STATUS CHANGED REPORT"
+5 SET Y=DT
DO DD^%DT
WRITE ?60,"Date: ",Y
+6 WRITE !?20,DG1_" TO "_DG2
+7 WRITE ?60,"Page: "_PAGE
+8 WRITE !!!?3,"NAME",?41,"SSN",?63,"CV END DATE",!?41,"PRIORITY GROUP"
+9 WRITE !,?3,"===================================",?41,"=================",?63,"============"
+10 SET PAGE=PAGE+1
+11 QUIT
DATA ;
+1 NEW DGENR,DFN,DGNAM,DGSSN,DGDT,DGX,QUIT,Y,VADM
+2 SET QUIT=""
+3 if $GET(DGBEG)']""!($GET(DGEND)']"")
QUIT
+4 SET DGX=DGBEG-1
+5 FOR
SET DGX=$ORDER(^DPT("E",DGX))
if DGX'>0!(DGX>DGEND)
QUIT
Begin DoDot:1
+6 SET DFN=""
+7 FOR
SET DFN=$ORDER(^DPT("E",DGX,DFN))
if DFN']""!(QUIT)
QUIT
Begin DoDot:2
+8 if '$DATA(^DPT(DFN))
QUIT
+9 KILL VADM,DGENR
+10 DO DEM^VADPT
+11 if '$DATA(VADM)
QUIT
+12 SET DGNAM=VADM(1)
+13 SET DGSSN=$PIECE(VADM(2),U,2)
+14 SET DGDT=$$GET1^DIQ(2,DFN_",",.5295,"E")
+15 IF $GET(DGDT)']""
SET DGDT="DELETED!!!!"
+16 SET DGENR=$$PRIOR(DFN)
+17 IF $GET(DGENR)']""
SET DGENR="NONE"
+18 DO ADD2
End DoDot:2
End DoDot:1
+19 QUIT
PRIOR(DFN) ;gets priority and sub group
+1 ;
+2 NEW DGEN,DGIEN,DGSUB
+3 IF $$GET^DGENA($$FINDCUR^DGENA(DFN),.DGEN)
Begin DoDot:1
+4 SET DGENR=$GET(DGEN("PRIORITY"))
+5 SET DGSUB=$GET(DGEN("SUBGRP"))
+6 IF $GET(DGSUB)]""
SET DGENR=DGENR_$$EXTERNAL^DILFD(27.11,.12,"F",DGSUB)
End DoDot:1
+7 QUIT $GET(DGENR)
PAUSE ;
+1 NEW DIR,DIRUT,X,Y
+2 FOR
if $Y>(IOSL-3)
QUIT
WRITE !
+3 SET DIR(0)="E"
+4 DO ^DIR
+5 IF ('(+Y))!($DATA(DIRUT))
SET QUIT=1
+6 QUIT
ADD2 ;
+1 IF $EXTRACT(IOST,1,2)="C-"
IF ($Y>(IOSL-6))
Begin DoDot:1
+2 DO PAUSE
+3 if QUIT
QUIT
+4 DO TOP2
End DoDot:1
+5 IF '$EXTRACT(IOST,1,2)="C-"
IF ($Y>(IOSL-2))
DO TOP2
+6 IF '(QUIT)
DO LINE
+7 QUIT
TOP2 ;
+1 WRITE @IOF
+2 DO HDR2
+3 QUIT
LINE ;add a line to the report
+1 WRITE !?3,DGNAM,?41,DGSSN,?63,DGDT,!?41,DGENR,!
+2 SET DGLN=1
+3 QUIT
