DVBAUTL7 ;ALB/GTS;UTILITY ROUTINE;12/6/94
;;2.7;AMIE;**17**;Apr 10, 1995
;
;** Version Changes
; 2.7 - New routine (Enhc 16)
;
SEL7131() ;** Select a 7131 request
K Y
F DO Q:$D(Y)
.S DIC="^DVB(396,",DIC(0)="AEMQ"
.S DIC("W")="D REQDT^DVBAUTL7"
.D ^DIC
.D:+Y>0 CHECK
K DIC,X
Q +Y
;
CHECK ;** Check 7131 for a pending report
K DVBAOPEN
N DVBAX
F DVBAX=9,11,13,15,17,19,21,23,7,28,26 DO
.I '$D(DVBAOPEN) DO
..I DVBAX'=7 DO
...S:$P(^DVB(396,+Y,0),U,DVBAX)="P" DVBAOPEN=""
..I DVBAX=7 DO
...S:$P(^DVB(396,+Y,1),U,DVBAX)="P" DVBAOPEN=""
I '$D(DVBAOPEN) K Y
I '$D(DVBAOPEN) DO
.S VAR(1,0)="1,0,0,2:2,0^You must select a 7131 with Pending reports!"
.D WR^DVBAUTL4("VAR")
.K VAR,PAR1,PAR2
K DVBAOPEN
Q
;
INITRPT(DVBAIEN) ;** Set nodes for division updates on 7131
;** Variable Descriptions
; DVBARPT(RPT #)=Report name^Selected - Y/N^Status - P/C^Division #
; DVBA0 and DVBA6 are the 7131 rec's 0 and 6 node respectively
;
;** Note: DVBARPT local array returned to calling rtn
;
N DVBA0,DVBA6,DVBAX,SUBSCPT,RPTNME,RPTSTAT,RPTSEL,SELPCE,DVBADIV,DIVNUM
S DVBA0=^DVB(396,DVBAIEN,0)
S:$D(^DVB(396,DVBAIEN,6)) DVBA6=^DVB(396,DVBAIEN,6)
S:'$D(^DVB(396,DVBAIEN,6)) DVBA6=""
S SUBSCPT=0
F DVBAX=9,11,13,15,17,19,21,23,7,28,26 DO ;**Subscpt's = Status Pce's
.S SUBSCPT=SUBSCPT+1
.S RPTNME=$T(@DVBAX)
.S RPTNME=$P(RPTNME,";;",2)
.I DVBAX'=7 DO ;**Set up Rpt Selection Pce #'s
..I DVBAX<17 DO
...S:DVBAX=9 SELPCE=5
...S:DVBAX=11 SELPCE=6
...S:DVBAX=13 SELPCE=7
...S:DVBAX=15 SELPCE=8
..S:(DVBAX>15&(DVBAX'=26)) SELPCE=DVBAX-1
..S RPTSTAT=$P(^DVB(396,DVBAIEN,0),U,DVBAX)
.S:DVBAX=7 RPTSTAT=$P(^DVB(396,DVBAIEN,1),U,DVBAX),SELPCE=24
.S:DVBAX'=26 RPTSEL=$P(^DVB(396,DVBAIEN,0),U,SELPCE)
.I DVBAX=26 DO
..S SELPCE=25
..S:$P(^DVB(396,DVBAIEN,0),U,SELPCE)'="" RPTSEL="YES"
..S:$P(^DVB(396,DVBAIEN,0),U,SELPCE)="" RPTSEL="NO"
.S DIVNUM=$P(DVBA6,U,DVBAX)
.S:+DIVNUM>0 DVBADIV=$P(^DG(40.8,DIVNUM,0),U,1)
.S:+DIVNUM'>0 DVBADIV=""
.S DVBARPT(SUBSCPT)=RPTNME_"^"_RPTSEL_"^"_RPTSTAT_"^"_DVBADIV_"^"_DIVNUM_"^"_DIVNUM
Q
;
SETDR ;** Set DR string for 7131 division/tran date field updates
S:$D(DR) DR=DR_";"_FLDDIV_"///"_REQDIV_";"_FLDDTE_"///"_REQDTE
S:'$D(DR) DR=FLDDIV_"///"_REQDIV_";"_FLDDTE_"///"_REQDTE
Q
;
CLEARDR ;** Set DR string to clear 7131 division/tran date fields (7131 edit)
S:$D(DR) DR=DR_";"_FLDDIV_"///@;"_FLDDTE_"///@"
S:'$D(DR) DR=FLDDIV_"///@;"_FLDDTE_"///@"
Q
;
REQDT ;** Output 7131 date for DIC("W")
N DVBADTE,DVBATIME,DVBADTWK,DVBAX
S DVBADTWK=$P(^DVB(396,+Y,0),U,4)
S DVBATIME=$P(DVBADTWK,".",2)
S DVBADTWK=$P(DVBADTWK,".",1)
S DVBADTE=$$FMTE^XLFDT(DVBADTWK,"5DZ")
I +DVBATIME>0 DO
.F DVBAX=$L(DVBATIME):1:3 S DVBATIME=DVBATIME_"0"
.S DVBATIME=$E(DVBATIME,1,2)_":"_$E(DVBATIME,3,4)
.S DVBADTE=DVBADTE_" @ "_DVBATIME
W ?35,$S($P(^(2),U,10)="L":"Activity Date: ",$P(^(2),U,10)="A":"Admission Date: ",1:""),DVBADTE
Q
;
FILE ;** Update 7131 record - Called from DVBADXFR
N DVBAX,DVBADTWK
S DVBADTWK=DVBATDT
S DVBADTWK=$P(DVBATDT,"@",2)
S REQDTE=$P(DVBATDT,"@",1)_"@"_$P(DVBADTWK,":",1)_":"_$P(DVBADTWK,":",2)
F DVBAX=1:1:11 DO
.I $P(DVBARPT(DVBAX),U,5)'=$P(DVBARPT(DVBAX),U,6) DO
..I DVBAX=1 DO
...S REQDIV=$P(DVBARPT(DVBAX),U,5)
...S FLDDIV=4.6,FLDDTE=4.7
...D SETDR
..I DVBAX=2 DO
...S REQDIV=$P(DVBARPT(DVBAX),U,5)
...S FLDDIV=5.6,FLDDTE=5.7
...D SETDR
..I DVBAX=3 DO
...S REQDIV=$P(DVBARPT(DVBAX),U,5)
...S FLDDIV=6.6,FLDDTE=6.7
...D SETDR
..I DVBAX=4 DO
...S REQDIV=$P(DVBARPT(DVBAX),U,5)
...S FLDDIV=7.6,FLDDTE=7.7
...D SETDR
..I DVBAX=5 DO
...S REQDIV=$P(DVBARPT(DVBAX),U,5)
...S FLDDIV=9.6,FLDDTE=9.7
...D SETDR
..I DVBAX=6 DO
...S REQDIV=$P(DVBARPT(DVBAX),U,5)
...S FLDDIV=11.6,FLDDTE=11.7
...D SETDR
..I DVBAX=7 DO
...S REQDIV=$P(DVBARPT(DVBAX),U,5)
...S FLDDIV=13.6,FLDDTE=13.7
...D SETDR
..I DVBAX=8 DO
...S REQDIV=$P(DVBARPT(DVBAX),U,5)
...S FLDDIV=15.6,FLDDTE=15.7
...D SETDR
..I DVBAX=9 DO
...S REQDIV=$P(DVBARPT(DVBAX),U,5)
...S FLDDIV=17.6,FLDDTE=17.7
...D SETDR
..I DVBAX=10 DO
...S REQDIV=$P(DVBARPT(DVBAX),U,5)
...S FLDDIV=20.6,FLDDTE=20.7
...D SETDR
..I DVBAX=11 DO
...S REQDIV=$P(DVBARPT(DVBAX),U,5)
...S FLDDIV=18.6,FLDDTE=18.7
...D SETDR
I $D(DR) DO
.S DIE="^DVB(396,"
.S DA=REQDA
.D ^DIE
.K DIE,DA,DR
Q
;
RPTNMS ;
9 ;;Notice of Discharge
11 ;;Hospital Summary
13 ;;Certificate (21-day)
15 ;;Other/Exam (Review Remarks)
17 ;;Special Report
19 ;;Competency Report
21 ;;VA Form 21-2680
23 ;;Asset Information
7 ;;Admission Report
28 ;;Beginning Date Care
26 ;;OPT Treatment Report (Date Range)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAUTL7 4730 printed Oct 16, 2024@17:43:14 Page 2
DVBAUTL7 ;ALB/GTS;UTILITY ROUTINE;12/6/94
+1 ;;2.7;AMIE;**17**;Apr 10, 1995
+2 ;
+3 ;** Version Changes
+4 ; 2.7 - New routine (Enhc 16)
+5 ;
SEL7131() ;** Select a 7131 request
+1 KILL Y
+2 FOR
Begin DoDot:1
+3 SET DIC="^DVB(396,"
SET DIC(0)="AEMQ"
+4 SET DIC("W")="D REQDT^DVBAUTL7"
+5 DO ^DIC
+6 if +Y>0
DO CHECK
End DoDot:1
if $DATA(Y)
QUIT
+7 KILL DIC,X
+8 QUIT +Y
+9 ;
CHECK ;** Check 7131 for a pending report
+1 KILL DVBAOPEN
+2 NEW DVBAX
+3 FOR DVBAX=9,11,13,15,17,19,21,23,7,28,26
Begin DoDot:1
+4 IF '$DATA(DVBAOPEN)
Begin DoDot:2
+5 IF DVBAX'=7
Begin DoDot:3
+6 if $PIECE(^DVB(396,+Y,0),U,DVBAX)="P"
SET DVBAOPEN=""
End DoDot:3
+7 IF DVBAX=7
Begin DoDot:3
+8 if $PIECE(^DVB(396,+Y,1),U,DVBAX)="P"
SET DVBAOPEN=""
End DoDot:3
End DoDot:2
End DoDot:1
+9 IF '$DATA(DVBAOPEN)
KILL Y
+10 IF '$DATA(DVBAOPEN)
Begin DoDot:1
+11 SET VAR(1,0)="1,0,0,2:2,0^You must select a 7131 with Pending reports!"
+12 DO WR^DVBAUTL4("VAR")
+13 KILL VAR,PAR1,PAR2
End DoDot:1
+14 KILL DVBAOPEN
+15 QUIT
+16 ;
INITRPT(DVBAIEN) ;** Set nodes for division updates on 7131
+1 ;** Variable Descriptions
+2 ; DVBARPT(RPT #)=Report name^Selected - Y/N^Status - P/C^Division #
+3 ; DVBA0 and DVBA6 are the 7131 rec's 0 and 6 node respectively
+4 ;
+5 ;** Note: DVBARPT local array returned to calling rtn
+6 ;
+7 NEW DVBA0,DVBA6,DVBAX,SUBSCPT,RPTNME,RPTSTAT,RPTSEL,SELPCE,DVBADIV,DIVNUM
+8 SET DVBA0=^DVB(396,DVBAIEN,0)
+9 if $DATA(^DVB(396,DVBAIEN,6))
SET DVBA6=^DVB(396,DVBAIEN,6)
+10 if '$DATA(^DVB(396,DVBAIEN,6))
SET DVBA6=""
+11 SET SUBSCPT=0
+12 ;**Subscpt's = Status Pce's
FOR DVBAX=9,11,13,15,17,19,21,23,7,28,26
Begin DoDot:1
+13 SET SUBSCPT=SUBSCPT+1
+14 SET RPTNME=$TEXT(@DVBAX)
+15 SET RPTNME=$PIECE(RPTNME,";;",2)
+16 ;**Set up Rpt Selection Pce #'s
IF DVBAX'=7
Begin DoDot:2
+17 IF DVBAX<17
Begin DoDot:3
+18 if DVBAX=9
SET SELPCE=5
+19 if DVBAX=11
SET SELPCE=6
+20 if DVBAX=13
SET SELPCE=7
+21 if DVBAX=15
SET SELPCE=8
End DoDot:3
+22 if (DVBAX>15&(DVBAX'=26))
SET SELPCE=DVBAX-1
+23 SET RPTSTAT=$PIECE(^DVB(396,DVBAIEN,0),U,DVBAX)
End DoDot:2
+24 if DVBAX=7
SET RPTSTAT=$PIECE(^DVB(396,DVBAIEN,1),U,DVBAX)
SET SELPCE=24
+25 if DVBAX'=26
SET RPTSEL=$PIECE(^DVB(396,DVBAIEN,0),U,SELPCE)
+26 IF DVBAX=26
Begin DoDot:2
+27 SET SELPCE=25
+28 if $PIECE(^DVB(396,DVBAIEN,0),U,SELPCE)'=""
SET RPTSEL="YES"
+29 if $PIECE(^DVB(396,DVBAIEN,0),U,SELPCE)=""
SET RPTSEL="NO"
End DoDot:2
+30 SET DIVNUM=$PIECE(DVBA6,U,DVBAX)
+31 if +DIVNUM>0
SET DVBADIV=$PIECE(^DG(40.8,DIVNUM,0),U,1)
+32 if +DIVNUM'>0
SET DVBADIV=""
+33 SET DVBARPT(SUBSCPT)=RPTNME_"^"_RPTSEL_"^"_RPTSTAT_"^"_DVBADIV_"^"_DIVNUM_"^"_DIVNUM
End DoDot:1
+34 QUIT
+35 ;
SETDR ;** Set DR string for 7131 division/tran date field updates
+1 if $DATA(DR)
SET DR=DR_";"_FLDDIV_"///"_REQDIV_";"_FLDDTE_"///"_REQDTE
+2 if '$DATA(DR)
SET DR=FLDDIV_"///"_REQDIV_";"_FLDDTE_"///"_REQDTE
+3 QUIT
+4 ;
CLEARDR ;** Set DR string to clear 7131 division/tran date fields (7131 edit)
+1 if $DATA(DR)
SET DR=DR_";"_FLDDIV_"///@;"_FLDDTE_"///@"
+2 if '$DATA(DR)
SET DR=FLDDIV_"///@;"_FLDDTE_"///@"
+3 QUIT
+4 ;
REQDT ;** Output 7131 date for DIC("W")
+1 NEW DVBADTE,DVBATIME,DVBADTWK,DVBAX
+2 SET DVBADTWK=$PIECE(^DVB(396,+Y,0),U,4)
+3 SET DVBATIME=$PIECE(DVBADTWK,".",2)
+4 SET DVBADTWK=$PIECE(DVBADTWK,".",1)
+5 SET DVBADTE=$$FMTE^XLFDT(DVBADTWK,"5DZ")
+6 IF +DVBATIME>0
Begin DoDot:1
+7 FOR DVBAX=$LENGTH(DVBATIME):1:3
SET DVBATIME=DVBATIME_"0"
+8 SET DVBATIME=$EXTRACT(DVBATIME,1,2)_":"_$EXTRACT(DVBATIME,3,4)
+9 SET DVBADTE=DVBADTE_" @ "_DVBATIME
End DoDot:1
+10 WRITE ?35,$SELECT($PIECE(^(2),U,10)="L":"Activity Date: ",$PIECE(^(2),U,10)="A":"Admission Date: ",1:""),DVBADTE
+11 QUIT
+12 ;
FILE ;** Update 7131 record - Called from DVBADXFR
+1 NEW DVBAX,DVBADTWK
+2 SET DVBADTWK=DVBATDT
+3 SET DVBADTWK=$PIECE(DVBATDT,"@",2)
+4 SET REQDTE=$PIECE(DVBATDT,"@",1)_"@"_$PIECE(DVBADTWK,":",1)_":"_$PIECE(DVBADTWK,":",2)
+5 FOR DVBAX=1:1:11
Begin DoDot:1
+6 IF $PIECE(DVBARPT(DVBAX),U,5)'=$PIECE(DVBARPT(DVBAX),U,6)
Begin DoDot:2
+7 IF DVBAX=1
Begin DoDot:3
+8 SET REQDIV=$PIECE(DVBARPT(DVBAX),U,5)
+9 SET FLDDIV=4.6
SET FLDDTE=4.7
+10 DO SETDR
End DoDot:3
+11 IF DVBAX=2
Begin DoDot:3
+12 SET REQDIV=$PIECE(DVBARPT(DVBAX),U,5)
+13 SET FLDDIV=5.6
SET FLDDTE=5.7
+14 DO SETDR
End DoDot:3
+15 IF DVBAX=3
Begin DoDot:3
+16 SET REQDIV=$PIECE(DVBARPT(DVBAX),U,5)
+17 SET FLDDIV=6.6
SET FLDDTE=6.7
+18 DO SETDR
End DoDot:3
+19 IF DVBAX=4
Begin DoDot:3
+20 SET REQDIV=$PIECE(DVBARPT(DVBAX),U,5)
+21 SET FLDDIV=7.6
SET FLDDTE=7.7
+22 DO SETDR
End DoDot:3
+23 IF DVBAX=5
Begin DoDot:3
+24 SET REQDIV=$PIECE(DVBARPT(DVBAX),U,5)
+25 SET FLDDIV=9.6
SET FLDDTE=9.7
+26 DO SETDR
End DoDot:3
+27 IF DVBAX=6
Begin DoDot:3
+28 SET REQDIV=$PIECE(DVBARPT(DVBAX),U,5)
+29 SET FLDDIV=11.6
SET FLDDTE=11.7
+30 DO SETDR
End DoDot:3
+31 IF DVBAX=7
Begin DoDot:3
+32 SET REQDIV=$PIECE(DVBARPT(DVBAX),U,5)
+33 SET FLDDIV=13.6
SET FLDDTE=13.7
+34 DO SETDR
End DoDot:3
+35 IF DVBAX=8
Begin DoDot:3
+36 SET REQDIV=$PIECE(DVBARPT(DVBAX),U,5)
+37 SET FLDDIV=15.6
SET FLDDTE=15.7
+38 DO SETDR
End DoDot:3
+39 IF DVBAX=9
Begin DoDot:3
+40 SET REQDIV=$PIECE(DVBARPT(DVBAX),U,5)
+41 SET FLDDIV=17.6
SET FLDDTE=17.7
+42 DO SETDR
End DoDot:3
+43 IF DVBAX=10
Begin DoDot:3
+44 SET REQDIV=$PIECE(DVBARPT(DVBAX),U,5)
+45 SET FLDDIV=20.6
SET FLDDTE=20.7
+46 DO SETDR
End DoDot:3
+47 IF DVBAX=11
Begin DoDot:3
+48 SET REQDIV=$PIECE(DVBARPT(DVBAX),U,5)
+49 SET FLDDIV=18.6
SET FLDDTE=18.7
+50 DO SETDR
End DoDot:3
End DoDot:2
End DoDot:1
+51 IF $DATA(DR)
Begin DoDot:1
+52 SET DIE="^DVB(396,"
+53 SET DA=REQDA
+54 DO ^DIE
+55 KILL DIE,DA,DR
End DoDot:1
+56 QUIT
+57 ;
RPTNMS ;
9 ;;Notice of Discharge
11 ;;Hospital Summary
13 ;;Certificate (21-day)
15 ;;Other/Exam (Review Remarks)
17 ;;Special Report
19 ;;Competency Report
21 ;;VA Form 21-2680
23 ;;Asset Information
7 ;;Admission Report
28 ;;Beginning Date Care
26 ;;OPT Treatment Report (Date Range)
+1 QUIT
