Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DVBAREQ3

DVBAREQ3.m

Go to the documentation of this file.
  1. DVBAREQ3 ;ALB/GTS-557/THM-PRINT ROUTINE NEW REQUEST RPT ;21 JUL 89
  1. ;;2.7;AMIE;**17,160**;Apr 10, 1995;Build 1
  1. ;
  1. PRINT S:$D(DVBATASK) ^TMP($J,LPDIV,DA)="" ;**Only 1 7131 printed per division
  1. S:'$D(DVBATASK) ^TMP($J,DA)="" ;**Only 1 7131 printed.
  1. 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)
  1. S ADIV=$S($D(^DVB(396,DA,2)):$P(^(2),U,9),1:"")
  1. I DVBSEL="D" Q:'$D(XDIV) D HEADER
  1. I DVBSEL="N" D HEADER2
  1. S NODTA=1
  1. W !,PNAM,?49,"SSN: ",SSN,!,?44,"CLAIM NO: ",CNUM,!,?38,$S(DOCTYPE="L":" ACTIVITY DATE: ",1:"ADMISSION DATE: "),$$FMTE^XLFDT(ADMDT,"5DZ"),!
  1. W ?40,"REQUEST DATE: ",$$FMTE^XLFDT(RDATE,"5DZ"),!!,?3,"Items Requested:",!
  1. ;
  1. ITEMS F Q=5,6,7,8,16,18,20,22,24,27 I $P(^DVB(396,DA,0),U,Q)'="NO" D PRINT1
  1. 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)
  1. S DVBAWO="N"
  1. K ^UTILITY($J,"W") W !!,"Remarks: " S DIWL=5,DIWR=65,DIWF="WB5I9"
  1. 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"
  1. K LPCNT,DIWL,DIWR,DIWF
  1. I DVBAWO="Y" D ^DIWW
  1. 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) "),!
  1. 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")
  1. I ADIV="" W !,?5,"**Request is incomplete, contact the Regional Office to complete**"
  1. 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
  1. W !! D TOP
  1. Q
  1. ;
  1. W !!!!!,"AMIE 7131 NEW REQUEST REPORT FOR ",$$FMTE^XLFDT(BDT,"5DZ")," TO ",$$FMTE^XLFDT(EDT,"5DZ")_" * LONG VERSION *",!
  1. I ADIV="" W ?5,"FOR ",HOSP,", DIVISION NOT GIVEN"
  1. 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",!!
  1. S DVBAON2=""
  1. Q
  1. ;
  1. PRINT1 D GETDIV
  1. 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
  1. 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
  1. Q
  1. ;
  1. 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
  1. Q
  1. ;
  1. HEADER2 ;prints a heading for the name selection
  1. I IOST?1"C-".E!($D(DVBAON2)) DO
  1. .S VAR(1,0)="0,0,0,0,1^"
  1. .D WR^DVBAUTL4("VAR")
  1. .K VAR
  1. .Q
  1. S VAR(1,0)="0,0,0,4:1,0^AMIE 7131 NEW REQUEST REPORT FOR "_PNAM_" **Long Version**"
  1. I ADIV="" S VAR(2,0)="0,0,5,0,0^FOR "_HOSP_", DIVISION NOT GIVEN"
  1. I ADIV'="" DO
  1. .S DIVHD=$S($D(^DG(40.8,ADIV,0)):$P(^(0),U,1),1:"")
  1. .S VAR(2,0)="0,0,5,1:2,0^FOR "_HOSP_", DIVISION "_$S(DIVHD]"":DIVHD,1:"UNABLE TO DETERMINE")
  1. .Q
  1. D WR^DVBAUTL4("VAR")
  1. K VAR
  1. Q
  1. ;
  1. GETDIV ;** Get the division for 7131 Rpt
  1. I $D(^DVB(396,DA,6)) DO
  1. .I Q=5 S GDIVPTR=$P(^DVB(396,DA,6),"^",9)
  1. .I Q=6 S GDIVPTR=$P(^DVB(396,DA,6),"^",11)
  1. .I Q=7 S GDIVPTR=$P(^DVB(396,DA,6),"^",13)
  1. .I Q=8 S GDIVPTR=$P(^DVB(396,DA,6),"^",15)
  1. .I Q=24 S GDIVPTR=$P(^DVB(396,DA,6),"^",7)
  1. .I Q>15&(Q'=24) DO
  1. ..S DVBAPCE=Q+1
  1. ..S GDIVPTR=$P(^DVB(396,DA,6),"^",DVBAPCE)
  1. ..K DVBAPCE
  1. S:'$D(GDIVPTR) GDIVPTR=$P(^DVB(396,DA,2),"^",9)
  1. I $D(GDIVPTR),(GDIVPTR="") S GDIVPTR=$P(^DVB(396,DA,2),"^",9)
  1. S GDIVNAM=$P(^DG(40.8,GDIVPTR,0),"^",1)
  1. K GDIVPTR
  1. Q
  1. ;
  1. FIELDS ;
  1. 5 ;;NOTICE OF DISCHARGE
  1. 6 ;;HOSPITAL SUMMARY
  1. 7 ;;21-DAY CERTIFICATE
  1. 8 ;;OTHER/EXAM REVIEW RMKS
  1. 16 ;;SPECIAL REPORT
  1. 18 ;;COMPETENCY REPORT
  1. 20 ;;VA FORM 21-2680
  1. 22 ;;ASSET INFORMATION
  1. 24 ;;ADMISSION REPORT
  1. 25 ;;OPT TREATMENT REPORT
  1. 27 ;;BEGINNING DATE/CARE
  1. Q