source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBY377PO.m@ 699

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

initial load of WorldVistAEHR
File size: 6.4 KB
Line 
1IBY377PO ;ALB/ESG - Post Install for IB patch 377 ;29-Nov-2007
2 ;;2.0;INTEGRATED BILLING;**377**;21-MAR-94;Build 23
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5EN ;
6 N XPDIDTOT S XPDIDTOT=5
7 D XREF ; 1. re-build DD cross reference
8 D PND ; 2. change one EDI reports menu mnemonic
9 D REL2 ; 3. populate new field 2.312/4.03
10 D REL355 ; 4. populate new field 355.33/60.14
11 D EMAIL ; 5. send email message to FSC
12 ;
13 ; remove identifier label from this field
14 KILL ^DD(355.93,0,"ID",.09) ; DBIA# 5131
15EX ;
16 Q
17 ;
18XREF ; Re-build DD cross references
19 NEW IBXR,IBRES,IBOUT,DIK
20 D BMES^XPDUTL(" STEP 1 of "_XPDIDTOT)
21 D MES^XPDUTL("-------------")
22 D MES^XPDUTL("Re-building the ""C"" cross-reference in file 364.6 ...")
23 KILL ^IBA(364.6,"C") ; kill whatever is there
24 S IBXR("FILE")=364.6
25 S IBXR("NAME")="C"
26 S IBXR("TYPE")="R"
27 S IBXR("USE")="LS"
28 S IBXR("EXECUTION")="F"
29 S IBXR("ACTIVITY")="IR"
30 S IBXR("SHORT DESCR")="Field name lookup"
31 S IBXR("VAL",1)=.1
32 S IBXR("VAL",1,"SUBSCRIPT")=1
33 S IBXR("VAL",1,"LENGTH")=40
34 S IBXR("VAL",1,"COLLATION")="F"
35 S IBXR("VAL",1,"XFORM FOR STORAGE")="S X=$$UP^XLFSTR(X)"
36 D CREIXN^DDMOD(.IBXR,"SW",.IBRES,"IBOUT")
37 S DIK="^IBA(364.6,",DIK(1)=".1^C" ; set-up
38 D ENALL^DIK ; rebuild it
39XREFX ;
40 D MES^XPDUTL(" Done.")
41 D UPDATE^XPDID(1)
42 Q
43 ;
44PND ; Change one EDI reports menu mnemonic
45 NEW MENUIEN,ITEMIEN,STOP,IBX,DIE,DA,DR
46 D BMES^XPDUTL(" STEP 2 of "_XPDIDTOT)
47 D MES^XPDUTL("-------------")
48 D MES^XPDUTL("Updating EDI reports menu mnemonic ....")
49 ;
50 S MENUIEN=$O(^DIC(19,"B","IBCE TXMT MGMNT REPORTS",0)) I 'MENUIEN G PNDX
51 S ITEMIEN=0,STOP=0
52 F S ITEMIEN=$O(^DIC(19,MENUIEN,10,ITEMIEN)) Q:'ITEMIEN D Q:STOP
53 . S IBX=$P($G(^DIC(19,MENUIEN,10,ITEMIEN,0)),U,1) Q:'IBX
54 . I $P($G(^DIC(19,IBX,0)),U,1)'="IBCE BATCHES PENDING TOO LONG" Q
55 . S DIE="^DIC(19,"_MENUIEN_",10,"
56 . S DA=ITEMIEN,DA(1)=MENUIEN
57 . S DR="2////PND"
58 . D ^DIE
59 . S STOP=1
60 . Q
61PNDX ;
62 D MES^XPDUTL(" Done.")
63 D UPDATE^XPDID(2)
64 Q
65 ;
66REL2 ; Populate new pt. relation field 2.312/4.03
67 ;
68 N IBCNT,IEN2,IEN2312,NODE,WINS,X12CODE
69 D BMES^XPDUTL(" STEP 3 of "_XPDIDTOT)
70 D MES^XPDUTL("-------------")
71 D MES^XPDUTL("Updating new patient relationship field in PATIENT file...")
72 ; If this patch has been installed before, then this update has already been completed.
73 I $$ICPLT() D MES^XPDUTL(" This field has already been updated. No further action.") G REL2X
74 D MES^XPDUTL("Each ""."" represents 10,000 records.")
75 D MES^XPDUTL("")
76 S (IEN2,IBCNT)=0 F S IEN2=$O(^DPT(IEN2)) Q:IEN2?1.A!(IEN2="") D
77 .S IBCNT=IBCNT+1 W:(IBCNT#10000=0)&'$D(ZTQUEUED) "."
78 .Q:'$D(^DPT(IEN2,.312)) ; make sure file 2.312 exists for this patient
79 .S IEN2312=0 F S IEN2312=$O(^DPT(IEN2,.312,IEN2312)) Q:IEN2312?1.A!(IEN2312="") D
80 ..S NODE=$G(^DPT(IEN2,.312,IEN2312,0)),X12CODE=$$PRELCNV^IBCNSP1($P(NODE,U,16),1)
81 ..; if we couldn't find a match, try to use WHOSE INSURANCE field
82 ..S:X12CODE="" WINS=$P(NODE,U,6),X12CODE=$S(WINS="v":"18",WINS="s":"01",1:"")
83 ..Q:X12CODE="" ; still no valid code - skip this record
84 ..N DIE,DR,DA
85 ..S DIE="^DPT("_IEN2_",.312,",DA=IEN2312,DA(1)=IEN2,DR="4.03////"_X12CODE D ^DIE
86 ..Q
87 .Q
88 D MES^XPDUTL(" Done.")
89REL2X ;
90 D UPDATE^XPDID(3)
91 D CLEAN^DILF
92 Q
93 ;
94REL355 ; Populate new pt. relation field 355.33/60.14
95 ;
96 N IEN355,NODE,WINS,X12CODE
97 D BMES^XPDUTL(" STEP 4 of "_XPDIDTOT)
98 D MES^XPDUTL("-------------")
99 D MES^XPDUTL("Updating new patient relationship field in INSURANCE BUFFER file...")
100 ; If this patch has been installed before, then this update has already been completed.
101 I $$ICPLT() D MES^XPDUTL(" This field has already been updated. No further action.") G REL355X
102 S IEN355=0 F S IEN355=$O(^IBA(355.33,IEN355)) Q:IEN355?1.A!(IEN355="") D
103 .S NODE=$G(^IBA(355.33,IEN355,60)) Q:NODE="" ; make sure that node 60 of file 355.33 exists
104 .S X12CODE=$$PRELCNV^IBCNSP1($P(NODE,U,6),1)
105 .; if we couldn't find a match, try to use WHOSE INSURANCE field
106 .S:X12CODE="" WINS=$P(NODE,U,5),X12CODE=$S(WINS="v":"18",WINS="s":"01",1:"")
107 .Q:X12CODE="" ; still no valid code - skip this record
108 .N DIE,DR,DA
109 .S DIE=355.33,DA=IEN355,DR="60.14////"_X12CODE D ^DIE
110 .Q
111 D MES^XPDUTL(" Done.")
112REL355X ;
113 D UPDATE^XPDID(4)
114 D CLEAN^DILF
115 Q
116 ;
117ICPLT() ; Returns 1 if this patch has been successfully installed before, 0 otherwise
118 N I,ICPLT,INST
119 D FIND^DIC(9.7,,"@;.02I","QPX","IB*2.0*377",,,,,"INST")
120 S (I,ICPLT)=0 F S I=$O(INST("DILIST",I)) Q:I="" S:+$P(INST("DILIST",I,0),U,2)=3 ICPLT=1 Q:ICPLT
121 Q ICPLT
122 ;
123EMAIL ; Send an email message to Austin FSC to let them know this site has installed IB patch 377
124 NEW SITE,SUBJ,MSG,XMTO,LN,GLO,GLB
125 D BMES^XPDUTL(" STEP 5 of "_XPDIDTOT)
126 D MES^XPDUTL("-------------")
127 D MES^XPDUTL("Sending email notification to Austin FSC ... ")
128 I '$$PROD^XUPROD(1) D MES^XPDUTL("No email sent for test account installation.") G EMAILX
129 S SITE=$$SITE^VASITE
130 S SUBJ="IB*2*377 installed at Station# "_$P(SITE,U,3)_" - "_$P(SITE,U,2)
131 S SUBJ=$E(SUBJ,1,65)
132 S MSG(1)="VistA patch IB*2.0*377 was installed successfully at the following site:"
133 S MSG(2)=""
134 S MSG(3)=" Name: "_$P(SITE,U,2)
135 S MSG(4)=" Station#: "_$P(SITE,U,3)
136 S MSG(5)=" Domain: "_$G(^XMB("NETNAME"))
137 S MSG(6)=" Date/Time: "_$$FMTE^XLFDT($$NOW^XLFDT,"5ZPM")
138 S MSG(7)=""
139 S MSG(8)="This patch is eClaims Plus Iteration 3, Phase 2."
140 ;
141 S XMTO("fsc.edi-team@va.gov")=""
142 S XMTO("Eric.Gustafson@va.gov")=""
143 S XMTO("Yan.Gurtovoy@va.gov")=""
144 S XMTO("Mary.Simons@va.gov")=""
145 ;
146 D SENDMSG^XMXAPI(DUZ,SUBJ,"MSG",.XMTO)
147 I '$D(^TMP("XMERR",$J)) G EMAILX ; no email problems
148 ;
149 D MES^XPDUTL("MailMan problem reported. Please review messages.")
150 S SUBJ="IB*2*377 email notification failure"
151 K MSG S LN=0
152 S LN=LN+1,MSG(LN)="MailMan reported the following error(s) when attempting to send the"
153 S LN=LN+1,MSG(LN)="installation notification message for IB patch 377."
154 S LN=LN+1,MSG(LN)=""
155 S (GLO,GLB)="^TMP(""XMERR"","_$J
156 S GLO=GLO_")"
157 F S GLO=$Q(@GLO) Q:GLO'[GLB S LN=LN+1,MSG(LN)=" "_GLO_" = "_$G(@GLO)
158 S LN=LN+1,MSG(LN)=""
159 S LN=LN+1,MSG(LN)="Please contact EPS and report this problem by entering a Remedy ticket"
160 S LN=LN+1,MSG(LN)="or by calling the VA Service Desk (ph. 1-888-596-4357)."
161 S LN=LN+1,MSG(LN)=""
162 S LN=LN+1,MSG(LN)="Austin FSC needs to be notified when this patch is installed."
163 S LN=LN+1,MSG(LN)=""
164 K XMTO
165 S XMTO(DUZ)=""
166 S XMTO("G.PATCHES")=""
167 D SENDMSG^XMXAPI(DUZ,SUBJ,"MSG",.XMTO)
168 D MES^XPDUTL(.MSG)
169 ;
170EMAILX ;
171 D MES^XPDUTL(" Done.")
172 D UPDATE^XPDID(5)
173 D CLEAN^DILF
174 Q
175 ;
Note: See TracBrowser for help on using the repository browser.