DGCV1.m

DGCV1 ;ALB/ERC,BRM - COMBAT VET REPORTS; 07/10/2003 ; 2/5/04 2:52pm

 ;;5.3;Registration;**528,565,1015**; Aug 13, 1993;Build 21

 ;

 ;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

DGCV1     ;ALB/ERC,BRM - COMBAT VET REPORTS; 07/10/2003 ; 2/5/04 2:52pm

 +1       ;;5.3;Registration;**528,565,1015**; Aug 13, 1993;Build 21

 +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