DVBAREQ3 ;ALB/GTS-557/THM-PRINT ROUTINE NEW REQUEST RPT ;21 JUL 89
;;2.7;AMIE;**17,160**;Apr 10, 1995;Build 1
;
PRINT S:$D(DVBATASK) ^TMP($J,LPDIV,DA)="" ;**Only 1 7131 printed per division
S:'$D(DVBATASK) ^TMP($J,DA)="" ;**Only 1 7131 printed.
S DFN=$P(^DVB(396,DA,0),U,1),ADMDT=$P(^(0),U,4),RDATE=$P(^(1),U,1),PNAM=$P(^DPT(DFN,0),U,1),SSN=$P(^(0),U,9),CNUM=$S($D(^(.31)):$P(^(.31),U,3),1:"Unknown"),DOCTYPE=$P(^DVB(396,DA,2),U,10)
S ADIV=$S($D(^DVB(396,DA,2)):$P(^(2),U,9),1:"")
I DVBSEL="D" Q:'$D(XDIV) D HEADER
I DVBSEL="N" D HEADER2
S NODTA=1
W !,PNAM,?49,"SSN: ",SSN,!,?44,"CLAIM NO: ",CNUM,!,?38,$S(DOCTYPE="L":" ACTIVITY DATE: ",1:"ADMISSION DATE: "),$$FMTE^XLFDT(ADMDT,"5DZ"),!
W ?40,"REQUEST DATE: ",$$FMTE^XLFDT(RDATE,"5DZ"),!!,?3,"Items Requested:",!
;
ITEMS F Q=5,6,7,8,16,18,20,22,24,27 I $P(^DVB(396,DA,0),U,Q)'="NO" D PRINT1
I $P(^DVB(396,DA,0),U,25)'="" S Q=25 D GETDIV S MC=$T(@Q),MD=$P(MC,";;",2) S GDIV=" ("_$E(GDIVNAM,1,(20+(23-$L(MC))))_")" W !,?8,MD,GDIV,": ",$P(^DVB(396,DA,0),U,25)
S DVBAWO="N"
K ^UTILITY($J,"W") W !!,"Remarks: " S DIWL=5,DIWR=65,DIWF="WB5I9"
F LPCNT=1:1 Q:'$D(^DVB(396,DA,5,LPCNT,0)) S X=$G(^DVB(396,DA,5,LPCNT,0)) D ^DIWP S DVBAWO="Y"
K LPCNT,DIWL,DIWR,DIWF
I DVBAWO="Y" D ^DIWW
K DVBAWO W !! W:$D(^DVB(396,DA,2)) "Requested by: ",$S($P(^DVB(396,DA,2),U,8)]"":$P(^(2),U,8),1:" (Not specified)")," AT ",$S($P(^(2),U,7)]"":$P(^(2),U,7),1:" (Not specified) "),!
I $D(^DVB(396,DA,1)) I $P(^DVB(396,DA,1),U,12)'="" S FNLDT=$P(^(1),U,12) W !!,"This record was FINALIZED on ",$$FMTE^XLFDT(FNLDT,"5DZ")
I ADIV="" W !,?5,"**Request is incomplete, contact the Regional Office to complete**"
I IOST?1"PK-"!(IOST?1"P-") W !!!!!,"Record Processing Notes: " F LN=1:1:50 W "-" ;print processing notes for admin folder if not going to a screen
W !! D TOP
Q
;
W !!!!!,"AMIE 7131 NEW REQUEST REPORT FOR ",$$FMTE^XLFDT(BDT,"5DZ")," TO ",$$FMTE^XLFDT(EDT,"5DZ")_" * LONG VERSION *",!
I ADIV="" W ?5,"FOR ",HOSP,", DIVISION NOT GIVEN"
I ADIV'="" S DIVHD=$S($D(^DG(40.8,ADIV,0)):$P(^(0),U,1),1:"") W ?5,"FOR ",HOSP W:DIVHD]"" ", DIVISION ",DIVHD,!! I DIVHD="" W ", UNABLE TO DETERMINE DIVISION",!!
S DVBAON2=""
Q
;
PRINT1 D GETDIV
I QQ S MC=$T(@Q),MD=$P(MC,";;",2) S GDIV=" ("_$E(GDIVNAM,1,(9+(23-$L(MD))))_")" W !,?8,MD,GDIV S QQ='QQ Q
I 'QQ S MC=$T(@Q),MD=$P(MC,";;",2) S GDIV=" ("_$E(GDIVNAM,1,(9+(22-$L(MD))))_")" W ?46,MD,GDIV S QQ='QQ
Q
;
TOP K ANS I IOST?1"C-".E,'$D(NOASK) W !!,*7,"Press RETURN to continue or ""^"" to stop " R ANS:DTIME S:'$T ANS=U I ANS=U S DA="",MA=9999999
Q
;
I IOST?1"C-".E!($D(DVBAON2)) DO
.S VAR(1,0)="0,0,0,0,1^"
.D WR^DVBAUTL4("VAR")
.K VAR
.Q
S VAR(1,0)="0,0,0,4:1,0^AMIE 7131 NEW REQUEST REPORT FOR "_PNAM_" **Long Version**"
I ADIV="" S VAR(2,0)="0,0,5,0,0^FOR "_HOSP_", DIVISION NOT GIVEN"
I ADIV'="" DO
.S DIVHD=$S($D(^DG(40.8,ADIV,0)):$P(^(0),U,1),1:"")
.S VAR(2,0)="0,0,5,1:2,0^FOR "_HOSP_", DIVISION "_$S(DIVHD]"":DIVHD,1:"UNABLE TO DETERMINE")
.Q
D WR^DVBAUTL4("VAR")
K VAR
Q
;
GETDIV ;** Get the division for 7131 Rpt
I $D(^DVB(396,DA,6)) DO
.I Q=5 S GDIVPTR=$P(^DVB(396,DA,6),"^",9)
.I Q=6 S GDIVPTR=$P(^DVB(396,DA,6),"^",11)
.I Q=7 S GDIVPTR=$P(^DVB(396,DA,6),"^",13)
.I Q=8 S GDIVPTR=$P(^DVB(396,DA,6),"^",15)
.I Q=24 S GDIVPTR=$P(^DVB(396,DA,6),"^",7)
.I Q>15&(Q'=24) DO
..S DVBAPCE=Q+1
..S GDIVPTR=$P(^DVB(396,DA,6),"^",DVBAPCE)
..K DVBAPCE
S:'$D(GDIVPTR) GDIVPTR=$P(^DVB(396,DA,2),"^",9)
I $D(GDIVPTR),(GDIVPTR="") S GDIVPTR=$P(^DVB(396,DA,2),"^",9)
S GDIVNAM=$P(^DG(40.8,GDIVPTR,0),"^",1)
K GDIVPTR
Q
;
FIELDS ;
5 ;;NOTICE OF DISCHARGE
6 ;;HOSPITAL SUMMARY
7 ;;21-DAY CERTIFICATE
8 ;;OTHER/EXAM REVIEW RMKS
16 ;;SPECIAL REPORT
18 ;;COMPETENCY REPORT
20 ;;VA FORM 21-2680
22 ;;ASSET INFORMATION
24 ;;ADMISSION REPORT
25 ;;OPT TREATMENT REPORT
27 ;;BEGINNING DATE/CARE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAREQ3 3995 printed Sep 23, 2025@19:18:03 Page 2
DVBAREQ3 ;ALB/GTS-557/THM-PRINT ROUTINE NEW REQUEST RPT ;21 JUL 89
+1 ;;2.7;AMIE;**17,160**;Apr 10, 1995;Build 1
+2 ;
PRINT ;**Only 1 7131 printed per division
if $DATA(DVBATASK)
SET ^TMP($JOB,LPDIV,DA)=""
+1 ;**Only 1 7131 printed.
if '$DATA(DVBATASK)
SET ^TMP($JOB,DA)=""
+2 SET DFN=$PIECE(^DVB(396,DA,0),U,1)
SET ADMDT=$PIECE(^(0),U,4)
SET RDATE=$PIECE(^(1),U,1)
SET PNAM=$PIECE(^DPT(DFN,0),U,1)
SET SSN=$PIECE(^(0),U,9)
SET CNUM=$SELECT($DATA(^(.31)):$PIECE(^(.31),U,3),1:"Unknown")
SET DOCTYPE=$PIECE(^DVB(396,DA,2),U,10)
+3 SET ADIV=$SELECT($DATA(^DVB(396,DA,2)):$PIECE(^(2),U,9),1:"")
+4 IF DVBSEL="D"
if '$DATA(XDIV)
QUIT
DO HEADER
+5 IF DVBSEL="N"
DO HEADER2
+6 SET NODTA=1
+7 WRITE !,PNAM,?49,"SSN: ",SSN,!,?44,"CLAIM NO: ",CNUM,!,?38,$SELECT(DOCTYPE="L":" ACTIVITY DATE: ",1:"ADMISSION DATE: "),$$FMTE^XLFDT(ADMDT,"5DZ"),!
+8 WRITE ?40,"REQUEST DATE: ",$$FMTE^XLFDT(RDATE,"5DZ"),!!,?3,"Items Requested:",!
+9 ;
ITEMS FOR Q=5,6,7,8,16,18,20,22,24,27
IF $PIECE(^DVB(396,DA,0),U,Q)'="NO"
DO PRINT1
+1 IF $PIECE(^DVB(396,DA,0),U,25)'=""
SET Q=25
DO GETDIV
SET MC=$TEXT(@Q)
SET MD=$PIECE(MC,";;",2)
SET GDIV=" ("_$EXTRACT(GDIVNAM,1,(20+(23-$LENGTH(MC))))_")"
WRITE !,?8,MD,GDIV,": ",$PIECE(^DVB(396,DA,0),U,25)
+2 SET DVBAWO="N"
+3 KILL ^UTILITY($JOB,"W")
WRITE !!,"Remarks: "
SET DIWL=5
SET DIWR=65
SET DIWF="WB5I9"
+4 FOR LPCNT=1:1
if '$DATA(^DVB(396,DA,5,LPCNT,0))
QUIT
SET X=$GET(^DVB(396,DA,5,LPCNT,0))
DO ^DIWP
SET DVBAWO="Y"
+5 KILL LPCNT,DIWL,DIWR,DIWF
+6 IF DVBAWO="Y"
DO ^DIWW
+7 KILL DVBAWO
WRITE !!
if $DATA(^DVB(396,DA,2))
WRITE "Requested by: ",$SELECT($PIECE(^DVB(396,DA,2),U,8)]"":$PIECE(^(2),U,8),1:" (Not specified)")," AT ",$SELECT($PIECE(^(2),U,7)]"":$PIECE(^(2),U,7),1:" (Not specified) "),!
+8 IF $DATA(^DVB(396,DA,1))
IF $PIECE(^DVB(396,DA,1),U,12)'=""
SET FNLDT=$PIECE(^(1),U,12)
WRITE !!,"This record was FINALIZED on ",$$FMTE^XLFDT(FNLDT,"5DZ")
+9 IF ADIV=""
WRITE !,?5,"**Request is incomplete, contact the Regional Office to complete**"
+10 ;print processing notes for admin folder if not going to a screen
IF IOST?1"PK-"!(IOST?1"P-")
WRITE !!!!!,"Record Processing Notes: "
FOR LN=1:1:50
WRITE "-"
+11 WRITE !!
DO TOP
+12 QUIT
+13 ;
WRITE @IOF
+1 WRITE !!!!!,"AMIE 7131 NEW REQUEST REPORT FOR ",$$FMTE^XLFDT(BDT,"5DZ")," TO ",$$FMTE^XLFDT(EDT,"5DZ")_" * LONG VERSION *",!
+2 IF ADIV=""
WRITE ?5,"FOR ",HOSP,", DIVISION NOT GIVEN"
+3 IF ADIV'=""
SET DIVHD=$SELECT($DATA(^DG(40.8,ADIV,0)):$PIECE(^(0),U,1),1:"")
WRITE ?5,"FOR ",HOSP
if DIVHD]""
WRITE ", DIVISION ",DIVHD,!!
IF DIVHD=""
WRITE ", UNABLE TO DETERMINE DIVISION",!!
+4 SET DVBAON2=""
+5 QUIT
+6 ;
PRINT1 DO GETDIV
+1 IF QQ
SET MC=$TEXT(@Q)
SET MD=$PIECE(MC,";;",2)
SET GDIV=" ("_$EXTRACT(GDIVNAM,1,(9+(23-$LENGTH(MD))))_")"
WRITE !,?8,MD,GDIV
SET QQ='QQ
QUIT
+2 IF 'QQ
SET MC=$TEXT(@Q)
SET MD=$PIECE(MC,";;",2)
SET GDIV=" ("_$EXTRACT(GDIVNAM,1,(9+(22-$LENGTH(MD))))_")"
WRITE ?46,MD,GDIV
SET QQ='QQ
+3 QUIT
+4 ;
TOP KILL ANS
IF IOST?1"C-".E
IF '$DATA(NOASK)
WRITE !!,*7,"Press RETURN to continue or ""^"" to stop "
READ ANS:DTIME
if '$TEST
SET ANS=U
IF ANS=U
SET DA=""
SET MA=9999999
+1 QUIT
+2 ;
+1 IF IOST?1"C-".E!($DATA(DVBAON2))
Begin DoDot:1
+2 SET VAR(1,0)="0,0,0,0,1^"
+3 DO WR^DVBAUTL4("VAR")
+4 KILL VAR
+5 QUIT
End DoDot:1
+6 SET VAR(1,0)="0,0,0,4:1,0^AMIE 7131 NEW REQUEST REPORT FOR "_PNAM_" **Long Version**"
+7 IF ADIV=""
SET VAR(2,0)="0,0,5,0,0^FOR "_HOSP_", DIVISION NOT GIVEN"
+8 IF ADIV'=""
Begin DoDot:1
+9 SET DIVHD=$SELECT($DATA(^DG(40.8,ADIV,0)):$PIECE(^(0),U,1),1:"")
+10 SET VAR(2,0)="0,0,5,1:2,0^FOR "_HOSP_", DIVISION "_$SELECT(DIVHD]"":DIVHD,1:"UNABLE TO DETERMINE")
+11 QUIT
End DoDot:1
+12 DO WR^DVBAUTL4("VAR")
+13 KILL VAR
+14 QUIT
+15 ;
GETDIV ;** Get the division for 7131 Rpt
+1 IF $DATA(^DVB(396,DA,6))
Begin DoDot:1
+2 IF Q=5
SET GDIVPTR=$PIECE(^DVB(396,DA,6),"^",9)
+3 IF Q=6
SET GDIVPTR=$PIECE(^DVB(396,DA,6),"^",11)
+4 IF Q=7
SET GDIVPTR=$PIECE(^DVB(396,DA,6),"^",13)
+5 IF Q=8
SET GDIVPTR=$PIECE(^DVB(396,DA,6),"^",15)
+6 IF Q=24
SET GDIVPTR=$PIECE(^DVB(396,DA,6),"^",7)
+7 IF Q>15&(Q'=24)
Begin DoDot:2
+8 SET DVBAPCE=Q+1
+9 SET GDIVPTR=$PIECE(^DVB(396,DA,6),"^",DVBAPCE)
+10 KILL DVBAPCE
End DoDot:2
End DoDot:1
+11 if '$DATA(GDIVPTR)
SET GDIVPTR=$PIECE(^DVB(396,DA,2),"^",9)
+12 IF $DATA(GDIVPTR)
IF (GDIVPTR="")
SET GDIVPTR=$PIECE(^DVB(396,DA,2),"^",9)
+13 SET GDIVNAM=$PIECE(^DG(40.8,GDIVPTR,0),"^",1)
+14 KILL GDIVPTR
+15 QUIT
+16 ;
FIELDS ;
5 ;;NOTICE OF DISCHARGE
6 ;;HOSPITAL SUMMARY
7 ;;21-DAY CERTIFICATE
8 ;;OTHER/EXAM REVIEW RMKS
16 ;;SPECIAL REPORT
18 ;;COMPETENCY REPORT
20 ;;VA FORM 21-2680
22 ;;ASSET INFORMATION
24 ;;ADMISSION REPORT
25 ;;OPT TREATMENT REPORT
27 ;;BEGINNING DATE/CARE
+1 QUIT
