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

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

initial load of WorldVistAEHR
File size: 9.2 KB
RevLine 
[613]1IB20P279 ;ISP/TDP - IB*2*279 PRE-INIT ROUTINE ;07/21/2004
2 ;;2.0;INTEGRATED BILLING;**279**;21-MAR-94
3 ;
4ENV ; environment check
5PRE ; set up check points for pre-init
6 N %
7 S %=$$NEWCP^XPDUTL("PROVID","PROVID^IB20P279")
8 Q
9PROVID ;Search files 355.9 and 355.91 for invalid Care Unit pointers to file
10 ;355.96.
11 D BMES^XPDUTL("Beginning invalid Care Unit pointer search.")
12 D 3559,35591 I $D(^TMP($J,"IB20P279")) D MESSAGE
13 D COMPLETE
14 D END
15 Q
1635591 ;Search file 355.91 for invalid Care Unit pointers to file 355.96.
17 D BMES^XPDUTL("Searching for invalid Care Unit pointers in file 355.91.")
18 N DA,DIE,DR,IB35591,IBCARE,IBCIVAL,IBCNT,IBCU,IBCUCHK,IBECNT,IBFORM
19 N IBINS,IBINSNM,IBNUM,IBPRVID,IBPRVTYP
20 S (IBCNT,IBECNT,IBNUM)=0
21 S DIE="^IBA(355.91,"
22 F S IBNUM=$O(^IBA(355.91,IBNUM)) Q:IBNUM="" D
23 . I 'IBNUM Q
24 . S IB35591=$G(^IBA(355.91,IBNUM,0)) I IB35591="" Q
25 . S IBINS=$P(IB35591,U,1)
26 . S IBCU=$P(IB35591,U,3) I IBCU="" Q
27 . S IBFORM=$P(IB35591,U,4)
28 . S IBCARE=$P(IB35591,U,5)
29 . S IBPRVID=$P(IB35591,U,6)
30 . D VALIDCU I IBCIVAL=IBCU Q
31 . S IBCUCHK=0 D CUCHK I IBCUCHK D Q
32 .. S IBINSNM=$P($G(^DIC(36,IBINS,0)),U,1) I IBINSNM="" S IBINSNM="UNKNOWN (IEN "_IBINS_")"
33 .. S IBPRVTYP=$P($G(^IBE(355.97,IBPRVID,0)),U,1)
34 .. S ^TMP($J,"IB20P279",IBINSNM,IBPRVTYP,"<<INS CO DEFAULT>>",IBNUM)=IB35591
35 .. S IBECNT=IBECNT+1
36 .. D OUTPUT
37 . D FILE
38 D TOTALS
39 Q
403559 ;Search file 355.9 for invalid Care Unit pointers to file 355.96.
41 D BMES^XPDUTL("Searching for invalid Care Unit pointers in file 355.9.")
42 N DA,DIE,DR,IB3559,IBCARE,IBCIVAL,IBCNT,IBCU,IBCUCHK,IBECNT,IBFORM,IBGBL
43 N IBINS,IBINSNM,IBNAME,IBNUM,IBPROV,IBPRVID,IBPRVTYP
44 K ^TMP($J,"IB20P279")
45 S (IBCNT,IBECNT,IBNUM)=0
46 S DIE="^IBA(355.9,"
47 F S IBNUM=$O(^IBA(355.9,IBNUM)) Q:IBNUM="" D
48 . I 'IBNUM Q
49 . S IB3559=$G(^IBA(355.9,IBNUM,0)) I IB3559="" Q
50 . S IBPROV=$P(IB3559,U,1)
51 . S IBINS=$P(IB3559,U,2)
52 . S IBCU=$P(IB3559,U,3) I IBCU="" Q
53 . S IBFORM=$P(IB3559,U,4)
54 . S IBCARE=$P(IB3559,U,5)
55 . S IBPRVID=$P(IB3559,U,6)
56 . D VALIDCU I IBCIVAL=IBCU Q
57 . S IBCUCHK=0 D CUCHK I IBCUCHK D Q
58 .. S IBINSNM=$P($G(^DIC(36,IBINS,0)),U,1) I IBINSNM="" S IBINSNM="UNKNOWN (IEN "_IBINS_")"
59 .. S IBPRVTYP=$P($G(^IBE(355.97,IBPRVID,0)),U,1)
60 .. S IBGBL="^"_$P($G(IBPROV),";",2)_$P($G(IBPROV),";",1)_",0)"
61 .. S IBNAME=$P($G(@IBGBL),"^",1)
62 .. S ^TMP($J,"IB20P279",IBINSNM,IBPRVTYP,IBNAME,IBNUM)=IB3559
63 .. S IBECNT=IBECNT+1
64 .. D OUTPUT
65 . D FILE
66 D TOTALS
67 Q
68TOTALS ; Print cleanup totals.
69 N IBFILE
70 S IBFILE=$S(DIE["355.91":"355.91.",1:"355.9.")
71 I 'IBCNT,'IBECNT D BMES^XPDUTL("There were no invalid Care Unit pointers in file "_IBFILE) Q
72 I IBCNT D BMES^XPDUTL(IBCNT_" total invalid Care Unit pointer(s) were corrected in file "_IBFILE)
73 I IBECNT D BMES^XPDUTL(IBECNT_" total invalid Care Unit pointer(s) were NOT corrected in file "_IBFILE)
74 Q
75OUTPUT ; Failed conversion message.
76 D MES^XPDUTL("> Cannot change Care Unit Pointer for "_DIE_IBNUM_"). A Mailman")
77 D MES^XPDUTL(" message will be generated with more information.")
78 Q
79FILE ; Save change and display success message.
80 N IBL,IBLOCK,X
81 S IBL=0
82 S IBLOCK=DIE_IBNUM_")"
83 F X=1:1:10 L +@IBLOCK:2 H:'$T 5 I $T S IBL=1 Q
84 I 'IBL D Q
85 . S IBINSNM=$P($G(^DIC(36,IBINS,0)),U,1) I IBINSNM="" S IBINSNM="UNKNOWN (IEN "_IBINS_")"
86 . S IBPRVTYP=$P($G(^IBE(355.97,IBPRVID,0)),U,1)
87 . S IBGBL="^"_$P($G(IBPROV),";",2)_$P($G(IBPROV),";",1)_",0)"
88 . S IBNAME=$P($G(@IBGBL),"^",1)
89 . S ^TMP($J,"IB20P279",IBINSNM,IBPRVTYP,IBNAME,IBNUM)=$S($D(IB3559):IB3559,1:IB35591)
90 . S IBECNT=IBECNT+1
91 . D OUTPUT
92 S DA=IBNUM
93 S DR=".03////"_IBCIVAL
94 D ^DIE K DA,DR
95 L -@IBLOCK
96 D MES^XPDUTL("> Care Unit Pointer for "_DIE_IBNUM_") has been updated.")
97 S IBCNT=IBCNT+1
98 Q
99VALIDCU ;Checks for valid Care Unit combination.
100 ;Set IBCIVAL to insure Care Unit Pointer (355.9 and 355.91) is correct.
101 N IBCUVAL
102 S IBCUVAL=$P($G(^IBA(355.96,+IBCU,0)),U,1) I IBCUVAL="" S IBCIVAL="@" Q
103 S IBCIVAL=$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,IBFORM,IBCARE,IBPRVID,"")) I IBCIVAL'="" Q
104 S IBCIVAL=$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,IBFORM,0,IBPRVID,"")) I IBCIVAL'="" Q
105 S IBCIVAL=$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,IBCARE,IBPRVID,"")) I IBCIVAL'="" Q
106 S IBCIVAL=$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,0,IBPRVID,"")) I IBCIVAL'="" Q
107 S IBCIVAL="@"
108 Q
109CUCHK ;Checks for existing Care Unit combination.
110 I DIE="^IBA(355.91,",$D(^IBA(355.91,"AUNIQ",IBINS,$S(IBCIVAL="@":"*N/A*",IBCIVAL:IBCIVAL,1:$P(IB35591,U,10)),IBFORM,IBCARE,IBPRVID)) S IBCUCHK=1
111 I DIE="^IBA(355.9,",$D(^IBA(355.9,"AUNIQ",IBPROV,IBINS,$S(IBCIVAL="@":"*N/A*",IBCIVAL:IBCIVAL,1:$P(IB3559,U,16)),IBFORM,IBCARE,IBPRVID)) S IBCUCHK=1
112 Q
113MESSAGE ;Send message to user if unable to change Care Unit pointer(s).
114 N IBC,IBCARE,IBCNT,IBCU,IBDATA,IBFORM,IBGROUP,IBGRP,IBINS,IBMSG,IBNAME
115 N IBNCNT,IBNETNM,IBNME,IBNMSPC,IBNUM,IBPARAM,IBPRV,IBPRVID,IBTST,IBTXT
116 N XMDUZ,XMERR,XMSUB,XMTEXT,XMY
117 S XMSUB="PROVIDER ID CARE UNIT POINTERS INVALID"
118 I DUZ="" N DUZ S DUZ=.5 ; if user not defined set to postmaster
119 S XMDUZ=DUZ,XMTEXT="IBTXT"
120 S IBPARAM("FROM")="PATCH IB*2.0*279 PRE-INIT"
121 S IBGROUP="IB EDI SUPERVISOR"
122 S IBGRP=$O(^XMB(3.8,"B",IBGROUP,"")) I IBGRP D ; billing group defined
123 . I +$P($G(^XMB(3.8,IBGRP,1,0)),U,4)'>0 Q ; no members defined
124 . S XMY("G."_IBGROUP)="" ; send message to the group.
125 S XMY(DUZ)="" ; send message to user
126 S IBTST=".TEST.MIR.TST.MIRROR.TRAIN." ; various test names
127 S IBNETNM=$G(^XMB("NETNAME"))
128 I IBNETNM'="",('$F(IBTST,"."_$P(IBNETNM,".",1)_".")) S XMY("PHELPS,TY@FORUM.VA.GOV")=""
129 S IBC=0
130 S IBC=IBC+1,IBTXT(IBC)="This message has been sent by patch IB*2.0*279 at the completion of"
131 S IBC=IBC+1,IBTXT(IBC)="the pre-init routine."
132 S IBC=IBC+1,IBTXT(IBC)=" "
133 S IBC=IBC+1,IBTXT(IBC)="The Care Unit pointer values could not be corrected automatically for the"
134 S IBC=IBC+1,IBTXT(IBC)="following Provider ID entries. These entries need to be deleted or modified"
135 S IBC=IBC+1,IBTXT(IBC)="by choosing INSURANCE CO IDS from the Provider ID Maintenance [IBCE PROVIDER"
136 S IBC=IBC+1,IBTXT(IBC)="MAINT] menu option. If there is only one entry with the combination"
137 S IBC=IBC+1,IBTXT(IBC)="selected, then choose Edit an ID Record and accept all the defaults. The"
138 S IBC=IBC+1,IBTXT(IBC)="Care Unit combination pointer will be corrected. If there are two (2)"
139 S IBC=IBC+1,IBTXT(IBC)="identical entries, and you are unable to determine which one needs to be"
140 S IBC=IBC+1,IBTXT(IBC)="corrected, then delete both entries and then re-enter the data. If you are"
141 S IBC=IBC+1,IBTXT(IBC)="able to distinguish which entry is the invalid one, then you can either edit"
142 S IBC=IBC+1,IBTXT(IBC)="the Care Unit to a new one which does not create a duplicate combination or"
143 S IBC=IBC+1,IBTXT(IBC)="you may delete it. It is important that the invalid entry NOT be left"
144 S IBC=IBC+1,IBTXT(IBC)="unchanged on the system."
145 S IBC=IBC+1,IBTXT(IBC)=" "
146 S IBC=IBC+1,IBTXT(IBC)="INSURANCE CO."
147 S IBC=IBC+1,IBTXT(IBC)=" PROVIDER ID TYPE CARE"
148 S IBC=IBC+1,IBTXT(IBC)=" PROVIDER FORM TYPE CARE UNIT ID#"
149 S IBC=IBC+1,IBTXT(IBC)="==============================================================================="
150 S IBNMSPC=" "
151 S IBCNT=0,IBINS=""
152 F S IBINS=$O(^TMP($J,"IB20P279",IBINS)) Q:IBINS="" D
153 . S IBC=IBC+1,IBTXT(IBC)=" "
154 . S IBC=IBC+1,IBTXT(IBC)=IBINS
155 . S IBPRV=""
156 . F S IBPRV=$O(^TMP($J,"IB20P279",IBINS,IBPRV)) Q:IBPRV="" D
157 .. S IBC=IBC+1,IBTXT(IBC)=" "_IBPRV
158 .. S IBNAME=""
159 .. F S IBNAME=$O(^TMP($J,"IB20P279",IBINS,IBPRV,IBNAME)) Q:IBNAME="" D
160 ... S IBNME=$E(IBNAME_" ",1,24)_" "
161 ... S IBNCNT=0
162 ... S IBNUM=""
163 ... F S IBNUM=$O(^TMP($J,"IB20P279",IBINS,IBPRV,IBNAME,IBNUM)) Q:IBNUM="" D
164 .... S IBDATA=$G(^TMP($J,"IB20P279",IBINS,IBPRV,IBNAME,IBNUM)) I IBDATA="" Q
165 .... S IBFORM=$P(IBDATA,U,4),IBFORM=$E($S(IBFORM=1:"UB-92",IBFORM=2:"HCFA",1:"BOTH")_" ",1,5)_" "
166 .... S IBCARE=$P(IBDATA,U,5),IBCARE=$E($S(IBCARE=1:"INPT",IBCARE=2:"OUTPT",1:"INPT/OUTPT")_" ",1,10)_" "
167 .... S IBCU=$P($G(^IBA(355.95,$P($G(^IBA(355.96,$P(IBDATA,U,3),0)),"^",1),0)),"^",1),IBCU=$E(IBCU_" ",1,16)_" "
168 .... S IBPRVID=$E($P(IBDATA,U,7)_" ",1,14)
169 .... S IBC=IBC+1,IBTXT(IBC)=" "_$S(IBNCNT:IBNMSPC,1:IBNME)_IBFORM_IBCARE_IBCU_IBPRVID
170 .... S IBCNT=IBCNT+1
171 .... I 'IBNCNT S IBNCNT=1
172 S IBC=IBC+1,IBTXT(IBC)=" "
173 S IBC=IBC+1,IBTXT(IBC)=" "
174 S IBC=IBC+1,IBTXT(IBC)="Total records needing to be modified: "_IBCNT_"."
175 D SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.IBPARAM,"","")
176 S IBMSG(1)=" "
177 S IBMSG(2)="******************************************************************************"
178 S IBMSG(3)="** Provider ID Care Unit clean up message "_$S($D(XMERR):"not sent due to error in",1:"sent to the ")
179 I $D(XMERR) S IBMSG(4)="** message set up. Dumping message to screen."
180 I '$D(XMERR) S IBMSG(3)=IBMSG(3)_$S(DUZ=.5:"postmaster",1:"user")_$S('$D(XMY("G.IB EDI SUPERVISOR")):".",1:"")
181 I '$D(XMERR) S IBMSG(4)=$S($D(XMY("G.IB EDI SUPERVISOR")):"** and the IB EDI SUPERVISOR mail group.",1:"** Please forward message to your billing staff for action.")
182 S IBMSG(5)="******************************************************************************"
183 D BMES^XPDUTL(.IBMSG)
184 I $D(XMERR) D BMES^XPDUTL(" "),BMES^XPDUTL(.IBTXT)
185 K ^TMP($J,"IB20P279")
186 Q
187COMPLETE ; display message that step has completed
188 D BMES^XPDUTL("Step complete.")
189 Q
190END ; display message that pre-init has completed successfully
191 D BMES^XPDUTL("Pre-init complete")
192 Q
Note: See TracBrowser for help on using the repository browser.