- 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 Feb 18, 2025@23:08:27 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