source: WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBANDCU.m@ 738

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

initial load of WorldVistAEHR
File size: 4.9 KB
Line 
1DVBANDCU ;ALB/GTS - Clean-up routine 7131 ASIH notice of discharges; 12 Mar 96 @ 14:00pm [3/12/96 1:45pm]
2 ;;2/7;AMIE;**5**;Mar 12, 1996
3 ;
4TEXT ;;
5 ;;This routine will walk through the FORM 7131 file (#396) and cleanup
6 ;;any ASIH admission dates.
7 ;;
8 ;;Once the process has completed, a MailMan message will be
9 ;;delivered to the person installing the patch. The message
10 ;;will list 7131 requests that were cleaned up and Notices of
11 ;;Discharge generated. If Notices of Discharge were generated,
12 ;;it is recommended you forward this message to those Regional
13 ;;Office AMIE users so they will be aware of the changes to the
14 ;;data in the AMIE system.
15 ;;
16 ;;
17 ;;QUIT
18 ;
19STARTPT ;
20 S (LNI,LNX)=""
21 D MES^XPDUTL(" "),MES^XPDUTL(" ")
22 F LNI=1:1 S LNX=$P($T(TEXT+LNI),";;",2) Q:(LNX="QUIT") DO
23 .S:LNX="" LNX=" "
24 .D MES^XPDUTL(LNX)
25 D CLN7131
26 K LNI,LNX
27 Q
28 ;
29CLN7131 ;** Init process, call correction tag and send mail msg
30 S VAFEDXCT=0
31 D LINE("Results of AMIE 7131 ASIH clean-up at station "_$$SITE^VASITE())
32 D LINE("")
33 D LINE("Start time: "_$$NOW^XLFDT()),LINE("Job Number: "_$J)
34 D LINE(""),LINE("")
35 D LINE("This message was generated as part of the clean up performed with")
36 D LINE(" the installation of patch DVBA*2.7*5.")
37 D LINE("")
38 D LINE("IRM STAFF INFORMATION FOLLOWS: ")
39 D LINE("The following is a list of 7131 requests entered for an ASIH")
40 D LINE(" Admission date. The Admission Date field (#3) was changed so")
41 D LINE(" the time stamp no longer indicates ASIH."),LINE("")
42 D LINE("Only Regional Office Staff need be concerned with this.")
43 D LINE("")
44 D LINE("REGIONAL OFFICE STAFF INFORMATION FOLLOWS: ")
45 D LINE("R/O Staff, If you are adjudicating the claim of a veteran listed here,")
46 D LINE(" be aware that Notices of Discharge generated for the admission date noted")
47 D LINE(" may indicate discharge to another VA Facility.")
48 D LINE("Check the veteran's claim folder for determination of action necessary.")
49 D LINE(""),LINE("")
50 D CORRECT ;** Correct 7131 ASIH records
51 D LINE("")
52 D LINE("End time: "_$$NOW^XLFDT())
53 D MAIL ; mail results
54 Q
55 ;
56CORRECT ;** Walk 7131s, correct ASIH admit dts and gen 7132s
57 N CT,J,DVBARQDT,DVBAASIH,DVBAPAT,DVBADFN,DGPMDA,DGDT,TDIS
58 D SETXRO ;* Set RO station # array
59 S CT=0
60 S (J,DVBARQDT)=""
61 F S DVBARQDT=$O(^DVB(396,"G",DVBARQDT)) Q:(DVBARQDT="") DO
62 .F S J=$O(^DVB(396,"G",DVBARQDT,J)) Q:J="" DO
63 ..I $D(^DVB(396,J,0)),($D(^DVB(396,J,2))) DO
64 ...S DVBAASIH=$P(DVBARQDT,".",2)
65 ...I ($L(DVBAASIH)>6)&($P(^DVB(396,J,2),"^",10)="A") DO
66 ....S DVBADFN=$P(^DVB(396,J,0),"^",1)
67 ....S DVBAPAT=$P($G(^DPT(DVBADFN,0)),"^",1)
68 ....S:DVBAPAT="" DVBAPAT="(IRM NOTE: Bad patient name for DFN "_DVBADFN_")"
69 ....S DFN=DVBADFN
70 ....S VAIP("D")=DVBARQDT
71 ....S VAIP("M")=0
72 ....D IN5^VADPT
73 ....S DGPMDA=VAIP(1)
74 ....S DGDT=0
75 ....S DGDT=VAIP(17)
76 ....S TDIS=$P(VAIP(17,3),"^",2)
77 ....K VAIP,DFN
78 ....S DVBARQDT=+$E(DVBARQDT,1,14)
79 ....S DA=J,DIE="^DVB(396,",DR="3////^S X=DVBARQDT"
80 ....D ^DIE
81 ....K DIE,DR,X,DA
82 ....S Y=DVBARQDT
83 ....X ^DD("DD")
84 ....D LINE(" "_DVBAPAT_" 7131 for ASIH Admission Date "_Y_" corrected.")
85 ....K Y
86 ....D:DGDT GEN7132(DVBADFN,J,DVBARQDT,DGPMDA,TDIS)
87 ....S CT=CT+1
88 D:+CT'>0 LINE("No ASIH Admission 7131s were found for your Medical Center.")
89 D LINE(""),LINE("")
90 D LINE("The number of records corrected was "_CT)
91 D LINE(""),LINE("")
92 D:+CT>0 LINE("IRM PERSONNEL: ")
93 D:+CT>0 LINE("Please forward this message to Regional Office personnel who use your system.")
94 K XRO
95 Q
96 ;
97SETXRO ;* Set up regional office station numbers array
98 N I,J
99 F I=0:0 S I=$O(^DVB(396.1,1,1,I)) Q:I=""!(+I=0) S J=$P(^(I,0),U,1),J=$S($D(^DIC(4,+J,99)):$P(^(99),U),1:"") I J]"" S XRO(J)=""
100 Q
101 ;
102GEN7132(DFN,DVBADA,ADMDT,DGPMDA,TDIS) ;* Gen Notice of Discharge (file 396.2)
103 ;**NOTE: XRO(n) Array must be defined with N being the RO station #s
104 N CFLOC
105 S CFLOC=$P($G(^DPT(DFN,.31)),"^",4)
106 S:CFLOC'="" CFLOC=$S($D(^DIC(4,CFLOC,99)):$P(^DIC(4,CFLOC,99),"^",1),1:"")
107 Q:CFLOC="" ;QUIT:no CFLOC
108 I '$D(XRO(CFLOC))&(CFLOC'=376) Q ;**QUIT if RO not user at site
109 I CFLOC=376,TDIS["DEATH" S CFLOC=$O(XRO(0)) Q:CFLOC="" ;QUIT:no RO'S
110 Q:$D(^DVB(396.2,"D",ADMDT,DFN)) ;**QUIT if 7132 exists
111 I ($P(^DVB(396,DVBADA,0),U,5)="YES")&($P(^(0),U,9)="P") DO
112 .S SSN=$P($G(^DPT(DFN,0)),"^",9)
113 .S (DIC,DIE)="^DVB(396.2,"
114 .S DR="3.5///"_CFLOC_";1///"_ADMDT_";2///"_DGPMDA_";3///R"
115 .S DLAYGO=396.2,DIC(0)="QLM",X=""""_SSN_""""
116 .D ^DIC
117 .I +Y>0 DO
118 ..S DA=+Y
119 ..D ^DIE
120 ..D LINE(" .....Notice of Discharge has been generated!")
121 ..D LINE(""),LINE("")
122 .K DR,DLAYGO,DIC,DIE,X,Y,SSN
123 Q
124 ;
125MAIL ;** Mail Cleanup msg
126 N DIFROM
127 K XMY
128 S XMSUB="AMIE 7131 ASIH clean up"
129 S XMN=0
130 S XMTEXT="^TMP(""DVBA ASIH CLEANUP"",$J,"
131 S XMDUZ=.5,XMY(DUZ)=""
132 D ^XMD
133 D MES^XPDUTL(" "),MES^XPDUTL(" ")
134 D MES^XPDUTL(" ...Message has been delivered to installer!")
135 K VAFEDXCT,XMDUZ,XMN,XMSUB,XMTEXT,XMY,^TMP("DVBA ASIH CLEANUP",$J)
136 Q
137 ;
138LINE(TEXT) ; add line to array for e-mail
139 S VAFEDXCT=VAFEDXCT+1,^TMP("DVBA ASIH CLEANUP",$J,VAFEDXCT)=TEXT
140 Q
Note: See TracBrowser for help on using the repository browser.