source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOPF.m@ 1505

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1RMPOPF ;HINES-FO/DDA - MAIN INTERFACE ROUTINE FOR PFSS AND HOME OXYGEN ;8/18/05
2 ;;3.0;PROSTHETICS;**98**;Feb 09, 1996
3EN ; ENTRY POINT FOR HOME OXYGEN BACKGROUND PROCESSING
4 ; Loop on APNEW and APO cross-references.
5 D APNEW,APO
6 K RMPR6699,RMPRACCT,RMPRAPLR,RMPRDFN,RMPRDG1,RMPRDRG,RMPREVNT,RMPRHCPC,RMPRHCPT,RMPRIEN,RMPRITEM,RMPRPAR,RMPRPR1,RMPRPV1,RMPRPV2,RMPRRX,RMPRRXDT,RMPRRXEX,RMPRRXI,RMPRRXLP,RMPRSITE,RMPRSTAT,RMPRZCL
7 Q
8APNEW ;Loop on file #665 APNEW cross-reference.
9 ; Delete ITEM'S PFSS ACCOUNT REFERENCE associated with previous prescription date.
10 ; Set PFSS ACCOUNT FLAG. This will trigger the background process to obtain a new
11 ; PFSS ACCOUNT REFERENCE for the new prescription date.
12 S RMPRIEN=0
13 F S RMPRIEN=$O(^RMPR(665,"APNEW",1,RMPRIEN)) Q:RMPRIEN'>0 D
14 .; Check for valid prescription
15 .D VALIDRX
16 .I RMPRRXDT=0 D EXITNEW Q
17 .S RMPRITEM=0
18 .F S RMPRITEM=$O(^RMPR(665,RMPRIEN,"RMPOC",RMPRITEM)) Q:RMPRITEM'>0 D
19 ..S DIE="^RMPR(665,"_RMPRIEN_",""RMPOC"","
20 ..S DA(1)=RMPRIEN,DA=RMPRITEM
21 ..S DR="101///@;100///1"
22 ..D ^DIE
23 ..K DIE,DA,DR
24 ..Q
25 .D EXITNEW
26 Q
27EXITNEW ; Remove the APNEW flag
28 S RMPRRX=0
29 F S RMPRRX=$O(^RMPR(665,"APNEW",1,RMPRIEN,RMPRRX)) Q:RMPRRX'>0 D
30 .S DIE="^RMPR(665,"_RMPRIEN_",""RMPOB"","
31 .S DA(1)=RMPRIEN,DA=RMPRRX
32 .S DR="100///@"
33 .D ^DIE
34 .K DIE,DA,DR
35 .Q
36 Q
37APO ;Loop on file #665 APO cross-reference and gather data for GETACCT api.
38 S RMPRIEN=0
39 F S RMPRIEN=$O(^RMPR(665,"APO",1,RMPRIEN)) Q:RMPRIEN'>0 D GETACCT
40 Q
41GETACCT ; ENTRY POINT TO SEND HOME OXYGEN ACCOUNT CREATION, PRE-CERTIFICATION
42 ;OR UPDATE DATA TO OBTAIN A PFSS ACCOUNT REFERENCE.
43 ; QUIT IF ALL VALID PRESCRIPTIONS HAVE EXPIRED.
44 D VALIDRX ; LOOP ON EACH ITEM
45 S RMPRITEM=0
46 F S RMPRITEM=$O(^RMPR(665,"APO",1,RMPRIEN,RMPRITEM)) Q:RMPRITEM'>0 D
47 .I RMPRRXDT=0 D Q
48 ..; Remove APO Flag
49 ..S DIE="^RMPR(665,"_RMPRIEN_",""RMPOC"","
50 ..S DA(1)=RMPRIEN,DA=RMPRITEM
51 ..S DR="100///@"
52 ..D ^DIE
53 ..K DIE,DA,DR
54 ..Q
55 .S RMPRDFN=RMPRIEN
56 .S RMPRPAR=$P($G(^RMPR(665,RMPRIEN,"RMPOC",RMPRITEM,"PFSS")),"^",2)
57 .S:RMPRPAR="" RMPREVNT="A05"
58 .S:RMPRPAR'="" RMPREVNT="A08"
59 .S RMPRAPLR="GETACCT;RMPOPF"
60 .S RMPRPV1(2)="O"
61 .S RMPRSTA=$P($G(^RMPR(665,RMPRIEN,0)),"^",2)
62 .D GETSITE^RMPRPF1
63 .S RMPRPV1(3)=RMPRHLOC
64 .S RMPRPV1(7)=$P($G(^RMPR(665,RMPRIEN,"RMPOB",RMPRRXI,"PFSS")),"^",2)
65 .S RMPRPV1(44)=RMPRRXDT
66 .S RMPRPV2(8)=RMPRRXDT
67 .; INSURE HCPCS IS CODE SET VERSIONED
68 .S RMPRHCPC=$P($G(^RMPR(665,RMPRIEN,"RMPOC",RMPRITEM,0)),"^",7),RMPRHCDT=RMPRRXDT
69 .D PSASHCPC
70 .; If HCPCS version check fails then quit, but leave APO Flag intact for future processing.
71 .; The HCPCS should eventually be corrected.
72 .Q:RMPRVHC=0
73 .S RMPRPR1(3)=RMPRVHC
74 .S RMPRPR1(4)=RMPRTHC
75 .S RMPRPR1(6)="O"
76 .; INSURE ICD9 IS CODE SET VERSIONED
77 .S RMPRDRG=$P($G(^RMPR(665,RMPRIEN,"RMPOC",RMPRITEM,0)),"^",8)
78 .S:RMPRDRG'="" RMPRDRG=$$STATCHK^ICDAPIU($P($G(^ICD9(RMPRDRG,0)),"^"),RMPRRXDT)
79 .S RMPRDG1(1,3)=""
80 .S:$P(RMPRDRG,"^")=1 RMPRDG1(1,3)=$P(RMPRDRG,"^",2),RMPRDG1(1,6)="F"
81 .;ZCL SEGMENT TO GO HERE
82 .S RMPRZCL=""
83 .; FIELDS NOT YET ENTERED.
84 .; Call GETACCT api
85 .S RMPRACCT=$$GETACCT^IBBAPI(RMPRDFN,RMPRPAR,RMPREVNT,RMPRAPLR,.RMPRPV1,.RMPRPV2,.RMPRPR1,.RMPRDG1,.RMPRZCL)
86 .; Store PFSS ACCOUNT REFERENCE data and Delete the APO flag.
87 .S DIE="^RMPR(665,"_RMPRIEN_",""RMPOC"","
88 .S DA(1)=RMPRIEN,DA=RMPRITEM
89 .S DR="100///@;101///`"_RMPRACCT
90 .D ^DIE
91 .K DIE,DA,DR
92 .K RMPRDFN,RMPRPAR,RMPREVNT,RMPRAPLR,RMPRPV1,RMPRPV2,RMPRSTA,RMPRHLOC,RMPRHCPC,RMPRPR1,RMPRDRG,RMPRDG1,RMPRZCL,RMPRACCT,RMPRSTAT,RMPRCHDT,RMPRVHC,RMPRTHC,RMPREHC
93 .Q
94EXITGET ;
95 K RMPRRXDT,RMPRRXI,RMPRITEM
96 Q
97PSASHCPC ; determine correct HCPCS code to send based on PSAS HCPCS.
98 ; UPON ENTRY RMPRHCPC = POINTER TO 661.1 AND RMPRHCDT = FILEMAN DATE
99 ; Returns with RMPRVHC having the correct value to pass to IBB.
100 I RMPRHCPC="" S RMPREHC="A9900",RMPRTHC="HCPCS DELETED" G CHK
101 S RMPREHC=$P($G(^RMPR(661.1,RMPRHCPC,0)),"^")
102 S RMPRTHC=$P($G(^RMPR(661.1,RMPRHCPC,0)),"^",2)
103CHK S RMPRSTAT=$$STATCHK^ICPTAPIU(RMPREHC,RMPRHCDT)
104 I ($A($E(RMPREHC,2,2))>64)!($P(RMPRSTAT,"^")=0) D
105 .S RMPREHC="A9900"
106 .S RMPRSTAT=$$STATCHK^ICPTAPIU(RMPREHC,RMPRHCDT)
107 .Q
108 I $P(RMPRSTAT,"^")=1 S RMPRVHC=$P(RMPRSTAT,"^",2) Q
109 S RMPRVHC=0
110 Q
111VALIDRX ; GET ASSOCIATED RX MAKE SURE IT HAS NOT EXPIRED.
112 S (RMPRRXLP,RMPRRX,RMPRRXI,RMPRRXEX,RMPRRXDT)=0
113 F S RMPRRXLP=$O(^RMPR(665,RMPRIEN,"RMPOB","B",RMPRRXLP)) Q:RMPRRXLP'>0 D
114 .F S RMPRRX=$O(^RMPR(665,RMPRIEN,"RMPOB","B",RMPRRXLP,RMPRRX)) Q:RMPRRX'>0 D
115 ..S:$P($G(^RMPR(665,RMPRIEN,"RMPOB",RMPRRX,0)),"^",3)'<DT RMPRRXEX=$P($G(^RMPR(665,RMPRIEN,"RMPOB",RMPRRX,0)),"^",3),RMPRRXDT=RMPRRXLP,RMPRRXI=RMPRRX
116 ..Q
117 .Q
118 K RMPRRXLP,RMPRRX,RMPRRXEX
119 Q
120ACCTCNCL ; ENTRY POINT TO SEND HOME OXYGEN ACCOUNT CANCELLATION DATA.
121 ; THIS TAG IS CALLED AS A ONE-TIME TASKMAN TASK LOADED FROM ACCTTASK^PMPOPF.
122 ; Input variables from TaskMan-
123 ; RMPRDFN = DA (also DFN)
124 ; RMPRRXDT = Home Oxygen Prescription date
125 ; RMPRRXEN = Home Oxygen Prescription IEN
126 ;
127 ;CHECK IF HOME OXYGEN PRESCRIPTION SUB RECORD HAS BEEN DELETED.
128 ; EXIT IF IT STILL EXISTS
129 G:$D(^RMPR(665,RMPRDFN,"RMPOB","B",RMPRRXDT,RMPRRXEN)) EXITCNCL
130 ; THE RECORD WAS DELETED
131 ; LOOP ON PATIENT'S ITEMS.
132 S RMPRITEM=0
133 F S RMPRITEM=$O(^RMPR(665,RMPRDFN,"RMPOC",RMPRITEM)) Q:RMPRITEM'>0 D CANCEL
134EXITCNCL ;
135 K RMPRDFN,RMPRRXDT,RMPRRXEN,RMPRITEM
136 Q
137CANCEL ; ENTRY POINT TO SEND HOME OXYGEN ACCOUNT CANCELLATION DATA.
138 ; THIS TAG IS CALLED AS A ONE-TIME TASKMAN TASK LOADED FROM ITEMTASK^PMPOPF.
139 ; Input variables from TaskMan-
140 ; RMPRDFN = DA (also DFN)
141 ; RMPRITEM = Home Oxygen Item IEN
142 ;
143 ;CHECK IF HOME OXYGEN PRESCRIPTION SUB RECORD HAS BEEN DELETED.
144 ; EXIT IF IT STILL EXISTS
145 ; SET FROM:
146 ; RMPRDFN = DFN SENT WITHIN TASKMAN
147 ; RMPRPAR = HOME OXYGEN ITEM (19.4); PFSS Account Reference (101)
148 ; RMPREVNT = "A38"
149 ; RMPRAPLR = "CANCEL1;RMPOPF"
150 ; RMPRPV1(2) = "O"
151 ; RMPRPV1(3) = FILE 669.9, FIELD 52
152 ; RMPRPV1(44) = THE HOME OXYGEN PRESCRIPTION DATE SENT WITHIN TASKMAN
153 S RMPRPAR=$P($G(^RMPR(665,RMPRDFN,"RMPOC",RMPRITEM,"PFSS")),"^",2)
154CANCEL1 ; ENTRY POINT FOR SINGLE ITEM DELETE (ITEMTASK)
155 S RMPREVNT="A38"
156 S RMPRAPLR="CANCEL1;RMPOPF"
157 S RMPRPV1(2)="O"
158 S RMPRSTA=$P($G(^RMPR(665,RMPRDFN,0)),"^",2)
159 D GETSITE^RMPRPF1
160 S RMPRPV1(3)=RMPRHLOC
161 S RMPRIEN=RMPRDFN D VALIDRX
162 S:RMPRRXDT'=0 RMPRPV1(44)=RMPRRXDT
163 ; SEND A38 GETACCT FOR THE ITEM
164 S RMPRCNCL=$$GETACCT^IBBAPI(RMPRDFN,RMPRPAR,RMPREVNT,RMPRAPLR,.RMPRPV1)
165 K RMPRPAR,RMPREVNT,RMPRAPLR,RMPRPV1,RMPRSTA,RMPRHLOC,RMPRCNCL
166 Q
167ACCTTASK ; FILE #665, HOME OXYGEN PRESCRITION; DATE FIELD MUMPS XREF KILL LOGIC.
168 ; TASKMAN LOAD A ONE TIME TASKMAN TASK.
169 Q:'+$$SWSTAT^IBBAPI()
170 N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC
171 S ZTIO="",ZTRTN="ACCTCNCL^RMPOPF",ZTDESC="Prosthetics Home Oxygen PFSS Account Cancel",ZTDTH=$H
172 S ZTSAVE("RMPRDFN")=DA(1),ZTSAVE("RMPRRXEN")=DA,ZTSAVE("RMPRRXDT")=X
173 D ^%ZTLOAD
174 Q
175ITEMTASK ; FILE #665, HOME OXYGEN ITEM; ITEM FIELD MUMPS XREF
176 ;KILL LOGIC.
177 ; TASKMAN LOAD A ONE TIME TASKMAN TASK.
178 Q:'+$$SWSTAT^IBBAPI()
179 S RMPRPAR=$P($G(^RMPR(665,DA(1),"RMPOC",DA,"PFSS")),"^",2)
180 N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC
181 S ZTIO="",ZTRTN="CANCEL1^RMPOPF",ZTDESC="Prosthetics Home Oxygen PFSS Item Cancel",ZTDTH=$H
182 S ZTSAVE("RMPRDFN")=DA(1),ZTSAVE("RMPRITEM")=DA,ZTSAVE("RMPRPAR")=RMPRPAR
183 D ^%ZTLOAD
184 K RMPRPAR
185 Q
186CHRGTASK ; FILE #665.72, BILLING MONTH; VENDOR; PATIENT; ITEM FIELD MUMPS XREF
187 ;KILL LOGIC.
188 ; TASKMAN LOAD A ONE TIME TASKMAN TASK.
189 Q:'+$$SWSTAT^IBBAPI()
190 S RMPRPFSS=^RMPO(665.72,DA(4),1,DA(3),1,DA(2),"V",DA(1),1,DA,"PFSS")
191 N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC
192 S ZTIO="",ZTRTN="CHRGCRED^RMPOPF1",ZTDESC="Prosthetics Home Oxygen PFSS Charge Credit",ZTDTH=$H
193 S ZTSAVE("RMPRDFN")=DA(1),ZTSAVE("RMPRITEM")=DA,ZTSAVE("RMPRVDR")=DA(2),ZTSAVE("RMPRBLDT")=DA(3),ZTSAVE("RMPRSITE")=DA(4)
194 S ZTSAVE("RMPRPFSS")=^RMPO(665.72,DA(4),1,DA(3),1,DA(2),"V",DA(1),1,DA,"PFSS")
195 D ^%ZTLOAD
196 Q
197CHARGE ; Called from RMPOPST3.
198 ;IMPORTANT VARIBLES PASSED IN FROM RMPOPST3.
199 ; D6I= FILE 660 IEN
200 ; RMPOXITE= FILE 665.72 SITE (IEN)
201 ; RMPODATE= FILE 665.72 BILLING MONTH mult IEN
202 ; RMPOVDR= FILE 665.72 VENDOR mult IEN (DINUM to 440)
203 ; DFN= FILE 665.72 PATIENT mult IEN (DINUM to 2)
204 ; ITM= FILE 665.72 ITEM mult IEN
205 ; TRXDT= Date TRX Built
206 ; ITMD= Item multiple zero node
207 ;
208 Q:'+$$SWSTAT^IBBAPI()
209 D CHARGE^RMPOPF1
210 Q
Note: See TracBrowser for help on using the repository browser.