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
Q
;
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
Q
;
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"
Q
;
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
Q
;
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=""
Q
;
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
Q
;
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)
Q
;
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
Q
--- 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
