source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBACRRP.m@ 1354

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

initial load of FOIAVistA 6/30/08 version
File size: 2.7 KB
Line 
1DVBACRRP ;ALB/GTS-557/THM-REPRINT 21-DAY CERT FOR MAS ;21 JUL 89
2 ;;2.7;AMIE;;Apr 10, 1995
3 D INIT
4 I 'CONT G KIL
5 S DVBSEL=$$SELECT^DVBAUTL5("Original Processing Date","21 Day Certificate")
6 I DVBSEL="D" S SDATE=$$DATE() G:SDATE<0 KIL
7 I DVBSEL="N" S XDA=$$PAT^DVBAUTL5("MAS") G:XDA<1 KIL
8 I DVBSEL=0 G KIL
9 D DEVICE
10 I 'CONT G KIL
11 D DATA
12 ;
13KIL D KILL
14 Q
15 ;
16DATA ;
17 I DVBSEL="D" DO
18 .U IO
19 .S NAME=""
20 .F J=0:0 S NAME=$O(^DVB(396,"B",NAME)) Q:NAME="" F XDA=0:0 S XDA=$O(^DVB(396,"B",NAME,XDA)) Q:XDA="" I $P(^DVB(396,XDA,0),U,14)=SDATE S DFN=$P(^(0),U,1) D CREATE
21 .Q
22 I DVBSEL="N" DO
23 .S DFN=$P(^DVB(396,XDA,0),U,1)
24 .D CREATE
25 .Q
26 I NODTA=0 DO
27 .S VAR(1,0)="0,0,0,2:2,0^No data found to reprint"
28 .D WR^DVBAUTL4("VAR")
29 .K VAR
30 .Q
31 Q
32 ;
33KILL K %DT(0),SDATE,DVBAON2,DVBSEL,VAR,CONT
34 I $D(ZTQUEUED) D KILL^%ZTLOAD
35 D KILL^DVBAUTIL
36 Q
37 ;
38CREATE ;CERTIFICATE CREATE
39 Q:'$D(^DVB(396,XDA,4))
40 I $D(^DVB(396,XDA,2)) Q:$P(^(2),U,10)="L"
41 I '$D(^DPT(DFN,0)) W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF
42 I '$D(^DPT(DFN,0)) W !!,"Patient record missing for DFN ",DFN,!!
43 I '$D(^DPT(DFN,0)) S DVBAON2="" Q
44 S PNAM=$P(^DPT(DFN,0),U,1),SSN=$P(^(0),U,9),CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Unknown")
45 S WARD=$P(^DVB(396,XDA,4),U,6),BED=$P(^(4),U,7),DCHGDT=$P(^(4),U,5),ADMDT=$P(^(0),U,4)
46 U IO W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF
47 W !,FDT(0),?32,"REPORT OF CONTACT",!,?31,"21-DAY CERTIFICATE",?(80-11),"PAGE: 1",!,?(80-$L(HD1)\2),HD1,!!!!!!!,"Patient name: ",?16,PNAM,!,?9,"SSN: ",?16,SSN,?33,"Claim #: ",?43,CNUM,!!,?9,"Ward: ",?16,WARD,?30,"Bed: ",?36,BED,!!!
48 W " The patient above has been hospitalized for 21 consecutive days ",!,"from " S Y=ADMDT X ^DD("DD") W Y," to " S Y=DCHGDT X ^DD("DD") W Y,", and the major diagnosis for",!,"this period is:",!!!!!!!!!!!!!!!!!!!!
49 W "Physician signature: " F LINE=$X:1:80 W "_"
50 W !!!," Approved by: " F LINE=$X:1:65 W "_"
51 W !!?5,"R0C 119",!
52 S NODTA=1
53 S DVBAON2=""
54 Q
55 ;
56INIT ;
57 K ^TMP($J)
58 S CONT=1,NODTA=0,HD="21-DAY CERTIFICATE REPRINTING"
59 D HOME^%ZIS
60 D NOPARM^DVBAUTL2
61 I $D(DVBAQUIT) S CONT=0 Q
62 S HD1=$$SITE^DVBCUTL4()
63 I '$D(DT) S X="T" D ^%DT S DT=Y
64 S Y=DT X ^DD("DD") S FDT(0)=Y
65 S VAR(1,0)="0,0,(IOM-$L(HD)\2),1:3,1:0^"_HD
66 D WR^DVBAUTL4("VAR")
67 K VAR
68 Q
69 ;
70DATE() ;THis function returns a date of the original request from the user.
71 S %DT(0)=-DT
72 S %DT("A")="Enter ORIGINAL PROCESSING DATE: ",%DT="AEQ"
73 D ^%DT
74 K %DT
75 Q Y
76 ;
77DEVICE ;
78 S VAR(1,0)="0,0,0,2:0,0^"
79 D WR^DVBAUTL4("VAR")
80 K VAR
81 S %ZIS="AEQ"
82 D ^%ZIS K %ZIS
83 I POP S CONT=0 Q
84 I $D(IO("Q")) DO
85 .S CONT=0
86 .S ZTIO=ION,ZTDESC="21-day Cert reprint",ZTRTN="DATA^DVBACRRP"
87 .F I="XDA","DVBSEL","FDT(0)","HD","HD1","SDATE","NODTA" S ZTSAVE(I)=""
88 .D ^%ZTLOAD
89 .D ^%ZISC
90 .I $D(ZTSK) DO
91 ..S VAR(1,0)="0,0,0,2:2,0^Request queued."
92 ..D WR^DVBAUTL4("VAR")
93 ..K VAR
94 ..Q
95 .Q
96 Q
Note: See TracBrowser for help on using the repository browser.