Routine: DVBAUTL2

DVBAUTL2 ;ALB/GTS-557/THM-AMIE UTILITIES ;24 AUG 89

 ;;2.7;AMIE;;Apr 10, 1995

REOPEN ;used by DVBAREG1 and DVBAREN1 only to re-log 7131s

 W *7,!!,"Are you sure you want to DELETE the existing 7131 for this date",!,"and log a NEW one" S %=2 D YN^DICN ;must be finalized to reopen

 I $D(%Y),%Y["?" W !!,"Enter Y to delete the finalized 7131 request that",!,"exists for this date and log a new one.",!!,"Enter N to leave the existing 7131 as is.",! G REOPEN

 I %'=1 S ONFILE=1 K OLDDA,%,%Y Q

 I '$D(DVBREQDT) W *7,!!,"Activity or admission date is missing !  Cannot reopen.",!! H 3 S ONFILE=1 Q

 K DIC("S"),DVBAEDT

 S OLDY=Y,OLDDA=DA,DIK="^DVB(396," D WAIT^DICD,^DIK S (DA,DINUM)=OLDDA,X=+DFN K DD,DO S DLAYGO=396,DIC(0)="EQLM",DIC="^DVB(396," D FILE^DICN ;use same IFN

 S DR="1////"_CNUM_";2////"_SSN_";3////"_DVBREQDT_";23////"_DT_";24////"_DT_";27////"_LOC_";28////"_OPER_";30////"_DVBDOC,DIE=DIC D ^DIE K DLAYGO

 W !!,*7,"You may now enter a new 7131 for this date.",!! H 2

 S Y=OLDY

 K OLDDA,%,%Y

NOPARM ;check for AMIE parameter setup

 I '$D(^DVB(396.1,1,0)) W !!,*7,"No site parameters have been setup in file 396.1.",!,"You must do this before running any reports.",!! S DVBAQUIT=1 H 3

ADTYPE W !!,"Do you want (A)&A, (P)ension, (S)ervice-connected, or AL(L) discharges ?  S// " R ADTYPE:DTIME I '$T!(ADTYPE=U) S DVBAQUIT=1 Q

 S X=ADTYPE X ^%ZOSF("UPPERCASE") S ADTYPE=Y

 S:ADTYPE="" ADTYPE="S" I ADTYPE'?1"A"&(ADTYPE'?1"S")&(ADTYPE'?1"L")&(ADTYPE'?1"P") W *7,!!,"Must be A for A&A, P for Pension, S for Service-connected, or L for All" G ADTYPE

 S HEAD=$S(ADTYPE="P":"PENSION",ADTYPE="A":"A&A",ADTYPE="S":"SERVICE-CONNECTED",ADTYPE="L":"COMPLETE",1:"UNKNOWN")_" DISCHARGE REPORT"

DELETE K OUT W !!,*7,"Are you sure you want to delete this request" S %=2 D YN^DICN I $D(DTOUT)!(%<0) Q  ;continue on timeout to set record

 I $D(%),%=1 S DIK="^DVB(396," D ^DIK S OUT=1 W "    ... deleted!",*7,!! H 2

CHKDIV ;** Check for selected Division on 7131

 K DVXST

 N ADIV

 S ADIV=$S($D(^DVB(396,D0,2)):$P(^(2),U,9),1:"""")

 S:XDIV=ADIV DVXST=""

 I '$D(DVXST) DO

 .N ADT

 .S ADT=""

 .F ADT=0:0 S ADT=$O(^DVB(396,"AF",D0,ADT)) Q:ADT=""!($D(DVXST))  DO

 ..S:($D(^DVB(396,"AF",D0,ADT,XDIV))) DVXST=""

WRDIV ;** Write Division for 7131 - Loop DA in 'AF' X-ref

 S TMP($J,"DVBA",$P(^(2),"^",9))=""

 F DVBADT=0:0 S DVBADT=$O(^DVB(396,"AF",DA,DVBADT)) Q:DVBADT=""  D LPDIV

W !

 KILL TMP($J,"DVBA"),DVBADT,DVBADIV,DVBANAM

LPDIV ;** Loop Division in 'AF' X-ref

 S DVBADIV=0

 F  S DVBADIV=$O(^DVB(396,"AF",DA,DVBADT,DVBADIV)) Q:DVBADIV=""  DO

 .I '$D(TMP($J,"DVBA",DVBADIV)) DO

 ..S DVBANAM=$P(^DG(40.8,DVBADIV,0),"^",1)

 ..S TMP($J,"DVBA",DVBADIV)=""

 ..W !,?68,$E(DVBANAM,1,9)

DIVUPDT ;** Update 7131 Rpt Divisions & Tran Dates on new 7131

 K DR,DIE,DA

 S REQDTE=$P(^DVB(396,DVBAENTR,1),U,1),REQDIV=$P(^DVB(396,DVBAENTR,2),U,9)

 S:'$D(^DVB(396,DVBAENTR,6)) DVBANEW=""

 S:'$D(DVBANEW) NODE6=^DVB(396,DVBAENTR,6)

 F LPPCE=1:1:10 DO

 .S:LPPCE=1 FLDDIV=4.6,FLDDTE=4.7

 .S:LPPCE=2 FLDDIV=5.6,FLDDTE=5.7

 .S:LPPCE=3 FLDDIV=6.6,FLDDTE=6.7

 .S:LPPCE=4 FLDDIV=7.6,FLDDTE=7.7

 .S:LPPCE=5 FLDDIV=9.6,FLDDTE=9.7

 .S:LPPCE=6 FLDDIV=11.6,FLDDTE=11.7

 .S:LPPCE=7 FLDDIV=13.6,FLDDTE=13.7

 .S:LPPCE=8 FLDDIV=15.6,FLDDTE=15.7

 .S:LPPCE=9 FLDDIV=17.6,FLDDTE=17.7

 .S:LPPCE=10 FLDDIV=20.6,FLDDTE=20.7

 .I $P(DVBARPT(LPPCE),U,3)="P" D NEWCHK^DVBAUTL8 ;**Check for new report

 .I $P(DVBARPT(LPPCE),U,3)="" D CLRCHK^DVBAUTL8 ;**Check to clear fields

 I $P(^DVB(396,DVBAENTR,0),U,26)="P" DO  ;**Check OPT TRT Rpt

 .S FLDDIV=18.6,FLDDTE=18.7

 .I $D(DVBANEW) D SETDR^DVBAUTL7 ;**OPT TRT Rpt included on new 7131

 .I '$D(DVBANEW),($P(NODE6,U,26)="") D SETDR^DVBAUTL7 ;**OPT Rpt Added

 I $P(^DVB(396,DVBAENTR,0),U,26)="" DO  ;**Check OPT TRT Rpt

 .I '$D(DVBANEW),($P(NODE6,U,26)'="") DO  ;**OPT Rpt deselected via edit

 ..S FLDDIV=18.6,FLDDTE=18.7

 ..D CLEARDR^DVBAUTL7

 I $D(DR) S DA=DVBAENTR,DIE="^DVB(396," D ^DIE

 K FLDDTE,FLDDIV,LPPCE,REQDTE,REQDIV,DA,DR,DIE,Y,DVBANEW,NODE6

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAUTL2   4074     printed  Mar 13, 2025@20:46:57                                                                                                                                                                                                    Page 2

DVBAUTL2  ;ALB/GTS-557/THM-AMIE UTILITIES ;24 AUG 89

 +1       ;;2.7;AMIE;;Apr 10, 1995

 +2       ;

REOPEN    ;used by DVBAREG1 and DVBAREN1 only to re-log 7131s

 +1       ;must be finalized to reopen

           WRITE *7,!!,"Are you sure you want to DELETE the existing 7131 for this date",!,"and log a NEW one"

           SET %=2

           DO YN^DICN

 +2        IF $DATA(%Y)

               IF %Y["?"

                   WRITE !!,"Enter Y to delete the finalized 7131 request that",!,"exists for this date and log a new one.",!!,"Enter N to leave the existing 7131 as is.",!

                   GOTO REOPEN

 +3        IF %'=1

               SET ONFILE=1

               KILL OLDDA,%,%Y

               QUIT

 +4        IF '$DATA(DVBREQDT)

               WRITE *7,!!,"Activity or admission date is missing !  Cannot reopen.",!!

               HANG 3

               SET ONFILE=1

               QUIT

 +5        KILL DIC("S"),DVBAEDT

 +6       ;use same IFN

           SET OLDY=Y

           SET OLDDA=DA

           SET DIK="^DVB(396,"

           DO WAIT^DICD

           DO ^DIK

           SET (DA,DINUM)=OLDDA

           SET X=+DFN

           KILL DD,DO

           SET DLAYGO=396

           SET DIC(0)="EQLM"

           SET DIC="^DVB(396,"

           DO FILE^DICN

 +7        SET DR="1////"_CNUM_";2////"_SSN_";3////"_DVBREQDT_";23////"_DT_";24////"_DT_";27////"_LOC_";28////"_OPER_";30////"_DVBDOC

           SET DIE=DIC

           DO ^DIE

           KILL DLAYGO

 +8        WRITE !!,*7,"You may now enter a new 7131 for this date.",!!

           HANG 2

 +9        SET Y=OLDY

 +10       KILL OLDDA,%,%Y

 +11       QUIT

 +12      ;

NOPARM    ;check for AMIE parameter setup

 +1        IF '$DATA(^DVB(396.1,1,0))

               WRITE !!,*7,"No site parameters have been setup in file 396.1.",!,"You must do this before running any reports.",!!

               SET DVBAQUIT=1

               HANG 3

 +2        QUIT

 +3       ;

ADTYPE     WRITE !!,"Do you want (A)&A, (P)ension, (S)ervice-connected, or AL(L) discharges ?  S// "

           READ ADTYPE:DTIME

           IF '$TEST!(ADTYPE=U)

               SET DVBAQUIT=1

               QUIT

 +1        SET X=ADTYPE

           XECUTE ^%ZOSF("UPPERCASE")

           SET ADTYPE=Y

 +2        if ADTYPE=""

               SET ADTYPE="S"

           IF ADTYPE'?1"A"&(ADTYPE'?1"S")&(ADTYPE'?1"L")&(ADTYPE'?1"P")

               WRITE *7,!!,"Must be A for A&A, P for Pension, S for Service-connected, or L for All"

               GOTO ADTYPE

 +3        SET HEAD=$SELECT(ADTYPE="P":"PENSION",ADTYPE="A":"A&A",ADTYPE="S":"SERVICE-CONNECTED",ADTYPE="L":"COMPLETE",1:"UNKNOWN")_" DISCHARGE REPORT"

 +4        QUIT

 +5       ;

DELETE    ;continue on timeout to set record

           KILL OUT

           WRITE !!,*7,"Are you sure you want to delete this request"

           SET %=2

           DO YN^DICN

           IF $DATA(DTOUT)!(%<0)

               QUIT

 +1        IF $DATA(%)

               IF %=1

                   SET DIK="^DVB(396,"

                   DO ^DIK

                   SET OUT=1

                   WRITE "    ... deleted!",*7,!!

                   HANG 2

 +2        QUIT

 +3       ;

CHKDIV    ;** Check for selected Division on 7131

 +1        KILL DVXST

 +2        NEW ADIV

 +3        SET ADIV=$SELECT($DATA(^DVB(396,D0,2)):$PIECE(^(2),U,9),1:"""")

 +4        if XDIV=ADIV

               SET DVXST=""

 +5        IF '$DATA(DVXST)

               Begin DoDot:1

 +6                NEW ADT

 +7                SET ADT=""

 +8                FOR ADT=0:0

                       SET ADT=$ORDER(^DVB(396,"AF",D0,ADT))

                       if ADT=""!($DATA(DVXST))

                           QUIT

                       Begin DoDot:2

 +9                        if ($DATA(^DVB(396,"AF",D0,ADT,XDIV)))

                               SET DVXST=""

                       End DoDot:2

               End DoDot:1

 +10       QUIT

 +11      ;

WRDIV     ;** Write Division for 7131 - Loop DA in 'AF' X-ref

 +1        SET TMP($JOB,"DVBA",$PIECE(^(2),"^",9))=""

 +2        FOR DVBADT=0:0

               SET DVBADT=$ORDER(^DVB(396,"AF",DA,DVBADT))

               if DVBADT=""

                   QUIT

               DO LPDIV

 +3        WRITE !

 +4        KILL TMP($JOB,"DVBA"),DVBADT,DVBADIV,DVBANAM

 +5        QUIT

 +6       ;

LPDIV     ;** Loop Division in 'AF' X-ref

 +1        SET DVBADIV=0

 +2        FOR

               SET DVBADIV=$ORDER(^DVB(396,"AF",DA,DVBADT,DVBADIV))

               if DVBADIV=""

                   QUIT

               Begin DoDot:1

 +3                IF '$DATA(TMP($JOB,"DVBA",DVBADIV))

                       Begin DoDot:2

 +4                        SET DVBANAM=$PIECE(^DG(40.8,DVBADIV,0),"^",1)

 +5                        SET TMP($JOB,"DVBA",DVBADIV)=""

 +6                        WRITE !,?68,$EXTRACT(DVBANAM,1,9)

                       End DoDot:2

               End DoDot:1

 +7        QUIT

 +8       ;

DIVUPDT   ;** Update 7131 Rpt Divisions & Tran Dates on new 7131

 +1        KILL DR,DIE,DA

 +2        SET REQDTE=$PIECE(^DVB(396,DVBAENTR,1),U,1)

           SET REQDIV=$PIECE(^DVB(396,DVBAENTR,2),U,9)

 +3        if '$DATA(^DVB(396,DVBAENTR,6))

               SET DVBANEW=""

 +4        if '$DATA(DVBANEW)

               SET NODE6=^DVB(396,DVBAENTR,6)

 +5        FOR LPPCE=1:1:10

               Begin DoDot:1

 +6                if LPPCE=1

                       SET FLDDIV=4.6

                       SET FLDDTE=4.7

 +7                if LPPCE=2

                       SET FLDDIV=5.6

                       SET FLDDTE=5.7

 +8                if LPPCE=3

                       SET FLDDIV=6.6

                       SET FLDDTE=6.7

 +9                if LPPCE=4

                       SET FLDDIV=7.6

                       SET FLDDTE=7.7

 +10               if LPPCE=5

                       SET FLDDIV=9.6

                       SET FLDDTE=9.7

 +11               if LPPCE=6

                       SET FLDDIV=11.6

                       SET FLDDTE=11.7

 +12               if LPPCE=7

                       SET FLDDIV=13.6

                       SET FLDDTE=13.7

 +13               if LPPCE=8

                       SET FLDDIV=15.6

                       SET FLDDTE=15.7

 +14               if LPPCE=9

                       SET FLDDIV=17.6

                       SET FLDDTE=17.7

 +15               if LPPCE=10

                       SET FLDDIV=20.6

                       SET FLDDTE=20.7

 +16      ;**Check for new report

                   IF $PIECE(DVBARPT(LPPCE),U,3)="P"

                       DO NEWCHK^DVBAUTL8

 +17      ;**Check to clear fields

                   IF $PIECE(DVBARPT(LPPCE),U,3)=""

                       DO CLRCHK^DVBAUTL8

               End DoDot:1

 +18      ;**Check OPT TRT Rpt

           IF $PIECE(^DVB(396,DVBAENTR,0),U,26)="P"

               Begin DoDot:1

 +19               SET FLDDIV=18.6

                   SET FLDDTE=18.7

 +20      ;**OPT TRT Rpt included on new 7131

                   IF $DATA(DVBANEW)

                       DO SETDR^DVBAUTL7

 +21      ;**OPT Rpt Added

                   IF '$DATA(DVBANEW)

                       IF ($PIECE(NODE6,U,26)="")

                           DO SETDR^DVBAUTL7

               End DoDot:1

 +22      ;**Check OPT TRT Rpt

           IF $PIECE(^DVB(396,DVBAENTR,0),U,26)=""

               Begin DoDot:1

 +23      ;**OPT Rpt deselected via edit

                   IF '$DATA(DVBANEW)

                       IF ($PIECE(NODE6,U,26)'="")

                           Begin DoDot:2

 +24                           SET FLDDIV=18.6

                               SET FLDDTE=18.7

 +25                           DO CLEARDR^DVBAUTL7

                           End DoDot:2

               End DoDot:1

 +26       IF $DATA(DR)

               SET DA=DVBAENTR

               SET DIE="^DVB(396,"

               DO ^DIE

 +27       KILL FLDDTE,FLDDIV,LPPCE,REQDTE,REQDIV,DA,DR,DIE,Y,DVBANEW,NODE6

 +28       QUIT

DVBAUTL2.m