- 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 Jan 18, 2025@02:43:36 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