source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBAREQ3.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1DVBAREQ3 ;ALB/GTS-557/THM-PRINT ROUTINE NEW REQUEST RPT ;21 JUL 89
2 ;;2.7;AMIE;**17**;Apr 10, 1995
3 ;
4PRINT S:$D(DVBATASK) ^TMP($J,LPDIV,DA)="" ;**Only 1 7131 printed per division
5 S:'$D(DVBATASK) ^TMP($J,DA)="" ;**Only 1 7131 printed.
6 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)
7 S ADIV=$S($D(^DVB(396,DA,2)):$P(^(2),U,9),1:"")
8 I DVBSEL="D" Q:'$D(XDIV) D HEADER
9 I DVBSEL="N" D HEADER2
10 S NODTA=1
11 W !,PNAM,?49,"SSN: ",SSN,!,?44,"CLAIM NO: ",CNUM,!,?38,$S(DOCTYPE="L":" ACTIVITY DATE: ",1:"ADMISSION DATE: "),$$FMTE^XLFDT(ADMDT,"5DZ"),!
12 W ?40,"REQUEST DATE: ",$$FMTE^XLFDT(RDATE,"5DZ"),!!,?3,"Items Requested:",!
13 ;
14ITEMS F Q=5,6,7,8,16,18,20,22,24,27 I $P(^DVB(396,DA,0),U,Q)'="NO" D PRINT1
15 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)
16 S DVBAWO="N"
17 K ^UTILITY($J,"W") W !!,"Remarks: " S DIWL=5,DIWR=65,DIWF="WB5I9"
18 F LPCNT=1:1 S X=($S($D(^DVB(396,DA,5,LPCNT,0)):^(0),1:"")) Q:X="" D ^DIWP S DVBAWO="Y"
19 K LPCNT,DIWL,DIWR,DIWF
20 I DVBAWO="Y" D ^DIWW
21 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) "),!
22 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")
23 I ADIV="" W !,?5,"**Request is incomplete, contact the Regional Office to complete**"
24 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
25 W !! D TOP
26 Q
27 ;
28HEADER W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF
29 W !!!!!,"AMIE 7131 NEW REQUEST REPORT FOR ",$$FMTE^XLFDT(BDT,"5DZ")," TO ",$$FMTE^XLFDT(EDT,"5DZ")_" * LONG VERSION *",!
30 I ADIV="" W ?5,"FOR ",HOSP,", DIVISION NOT GIVEN"
31 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",!!
32 S DVBAON2=""
33 Q
34 ;
35PRINT1 D GETDIV
36 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
37 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
38 Q
39 ;
40TOP 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
41 Q
42 ;
43HEADER2 ;prints a heading for the name selection
44 I IOST?1"C-".E!($D(DVBAON2)) DO
45 .S VAR(1,0)="0,0,0,0,1^"
46 .D WR^DVBAUTL4("VAR")
47 .K VAR
48 .Q
49 S VAR(1,0)="0,0,0,4:1,0^AMIE 7131 NEW REQUEST REPORT FOR "_PNAM_" **Long Version**"
50 I ADIV="" S VAR(2,0)="0,0,5,0,0^FOR "_HOSP_", DIVISION NOT GIVEN"
51 I ADIV'="" DO
52 .S DIVHD=$S($D(^DG(40.8,ADIV,0)):$P(^(0),U,1),1:"")
53 .S VAR(2,0)="0,0,5,1:2,0^FOR "_HOSP_", DIVISION "_$S(DIVHD]"":DIVHD,1:"UNABLE TO DETERMINE")
54 .Q
55 D WR^DVBAUTL4("VAR")
56 K VAR
57 Q
58 ;
59GETDIV ;** Get the division for 7131 Rpt
60 I $D(^DVB(396,DA,6)) DO
61 .I Q=5 S GDIVPTR=$P(^DVB(396,DA,6),"^",9)
62 .I Q=6 S GDIVPTR=$P(^DVB(396,DA,6),"^",11)
63 .I Q=7 S GDIVPTR=$P(^DVB(396,DA,6),"^",13)
64 .I Q=8 S GDIVPTR=$P(^DVB(396,DA,6),"^",15)
65 .I Q=24 S GDIVPTR=$P(^DVB(396,DA,6),"^",7)
66 .I Q>15&(Q'=24) DO
67 ..S DVBAPCE=Q+1
68 ..S GDIVPTR=$P(^DVB(396,DA,6),"^",DVBAPCE)
69 ..K DVBAPCE
70 S:'$D(GDIVPTR) GDIVPTR=$P(^DVB(396,DA,2),"^",9)
71 I $D(GDIVPTR),(GDIVPTR="") S GDIVPTR=$P(^DVB(396,DA,2),"^",9)
72 S GDIVNAM=$P(^DG(40.8,GDIVPTR,0),"^",1)
73 K GDIVPTR
74 Q
75 ;
76FIELDS ;
775 ;;NOTICE OF DISCHARGE
786 ;;HOSPITAL SUMMARY
797 ;;21-DAY CERTIFICATE
808 ;;OTHER/EXAM REVIEW RMKS
8116 ;;SPECIAL REPORT
8218 ;;COMPETENCY REPORT
8320 ;;VA FORM 21-2680
8422 ;;ASSET INFORMATION
8524 ;;ADMISSION REPORT
8625 ;;OPT TREATMENT REPORT
8727 ;;BEGINNING DATE/CARE
88 Q
Note: See TracBrowser for help on using the repository browser.