source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPF2.m@ 794

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

initial load of FOIAVistA 6/30/08 version
File size: 5.2 KB
Line 
1RMPRPF2 ;HOIFO/TH,DDA - PFSS CHARGE ;8/18/05
2 ;;3.0;PROSTHETICS;**98**;Feb 09, 1996
3 ;
4 ; This routine gets and stores a PFSS Charge ID, send charge message
5 ; and updated charge to IBB.
6 ;
7 ; DBIA # 4665 for GETCHGID^IBBAPI and CHARGE^IBBAPI
8 Q
9 ;
10EN ; Entry Point
11 ; Quit if no Delivery Date
12 I $P(^RMPR(660,RMPRDA,0),U,12)="" D DELAPD^RMPRPF1 Q
13 ; If no PFSS Account Reference, then attempt to get one
14 I $P(^RMPR(660,RMPRDA,"PFSS"),U,1)="" D
15 . S RMPRSWDT=$P($$SWSTAT^IBBAPI(),"^",2)
16 . ; quit if Delivery Date is not after PFSS Switch On date.
17 . Q:$P(^RMPR(660,RMPRDA,0),"^",12)<RMPRSWDT
18 . D EN2^RMPRPF1
19 . Q
20 ; If still no PFSS Account Reference, then record is not valid for PFSS- QUIT
21 I $P(^RMPR(660,RMPRDA,"PFSS"),U,1)="" D DELAPD^RMPRPF1 Q
22 ;
23 S RMPRFLAG=1
24 ; After Charge Msg sent (Charge ID exists); kill APD x-ref
25 ; if PSAS HCPCS did not get updated AND
26 ; if QTY did not get updated AND
27 ; if Total Cost did not get updated AND
28 ; if Ordering Provider did not get updated.
29 I $P(^RMPR(660,RMPRDA,"PFSS"),U,2)'="" D
30 . I $P($G(^RMPR(660,RMPRDA,1)),U,4)=$P($G(^RMPR(660,RMPRDA,"PFSS")),U,3) S RMPRFLAG=0 ; PSAS HCPCS
31 . E S RMPRFLAG=1 Q
32 . I $P(^RMPR(660,RMPRDA,0),U,7)=$P($G(^RMPR(660,RMPRDA,"PFSS")),U,4) S RMPRFLAG=0 ; QTY
33 . E S RMPRFLAG=1 Q
34 . I $P(^RMPR(660,RMPRDA,0),U,16)=$P($G(^RMPR(660,RMPRDA,"PFSS")),U,5) S RMPRFLAG=0 ; Total Cost
35 . E S RMPRFLAG=1 Q
36 . I $P($G(^RMPR(660,RMPRDA,10)),U,6)=$P($G(^RMPR(660,RMPRDA,"PFSS")),U,6) S RMPRFLAG=0 ; Ordering Provider
37 . E S RMPRFLAG=1 Q
38 I RMPRFLAG=0 D DELAPD^RMPRPF1
39 ;
40 ; Quit if QTY=0 or null
41 S (RMPRQTY,RMPRTC)=0
42 S RMPRQTY=$P(^RMPR(660,RMPRDA,0),U,7)
43 I RMPRQTY=0!(RMPRQTY="") D DELAPD^RMPRPF1 Q
44 ; Quit if Total Cost=0 or null
45 S RMPRTC=$P(^RMPR(660,RMPRDA,0),U,16)
46 I RMPRTC=0!(RMPRTC="") D DELAPD^RMPRPF1 Q
47 ;
48 I RMPRFLAG=1 D
49 . ; Check if PFSS Charge ID exists
50 . I $P($G(^RMPR(660,RMPRDA,"PFSS")),U,2)="" D GETUCID,STORE
51 . ; Get charge data
52 . D GETDATA
53 . ; Send charge data to IBB
54 . D SENDCHRG
55 . ; If charge msg was sent successfully,
56 . ; Update latest PSAS HCPCS, QTY, Total Cost, and Ordering Provider
57 . ; then kill the x-ref
58 . I RMPRCHRG'=0 D UPDATE D DELAPD^RMPRPF1
59 D EXIT
60 Q
61 ;
62GETUCID ; Obtain PFSS Charge ID
63 S RMPRUCID=""
64 S RMPRUCID=$$GETCHGID^IBBAPI()
65 Q
66 ;
67STORE ; Store PFSS Charge ID
68 L +^RMPR(660,RMPRDA)
69 S DIE="^RMPR(660,",DA=RMPRDA
70 S DR="101////^S X=RMPRUCID" D ^DIE
71 L -^RMPR(660,RMPRDA)
72 K DA,DIE,DR
73 Q
74 ;
75GETDATA ; Get Charge Data
76 S RMPRDFN=$P(^RMPR(660,RMPRDA,0),U,2) ; Patient ID
77 S RMPRARFN=$P($G(^RMPR(660,RMPRDA,"PFSS")),U,1) ; PFSS Acct Ref
78 S RMPRTYPE="CG" ; Charge Type = Debit
79 S RMPRUCID=$P($G(^RMPR(660,RMPRDA,"PFSS")),U,2) ; PFSS Charge ID
80 ;
81 ; FT1
82 S RMPRDEL=$P(^RMPR(660,RMPRDA,0),U,12)
83 S RMPRFT1(4)=RMPRDEL ; Delivery Date
84 S RMPRFT1(10)=RMPRQTY ; Transaction Quantity
85 S RMPRFT1(13)=423 ; Department Code
86 ; Ordering Provider/Ordered by Code
87 S RMPRORD=$P($G(^RMPR(660,RMPRDA,10)),U,6)
88 S RMPRFT1(21)=RMPRORD
89 ; Unit Cost = Total Cost/QTY
90 S RMPRFT1(22)=RMPRTC/RMPRQTY
91 ;
92 ; PR1
93 S RMPRHCPC=$P($G(^RMPR(660,RMPRDA,1)),"^",4)
94 S RMPRHCDT=$P(^RMPR(660,RMPRDA,0),"^")
95 D PSASHCPC^RMPOPF
96 S RMPRPR1(3)=RMPRVHC ; Procedure Code
97 S RMPRPR1(4)=RMPRTHC ; PSAS HCPCS text
98 ; Procedure Functional Type - I:Stock Issue;P:Purchasing
99 S RMPRPFT="",RMPRPFT=$S($P(^RMPR(660,RMPRDA,0),U,13)=11:"I",1:"P")
100 S RMPRPR1(6)=RMPRPFT
101 ;
102 ; PROS
103 S (RMPRVNDR,RMPROBL)=""
104 S RMPRVNDR=$P(^RMPR(660,RMPRDA,0),U,9)
105 S RMPRPROS(1)=RMPRVNDR ; Vendor
106 S RMPROBL=$E($P($G(^RMPR(660,RMPRDA,1)),U,1),1,30)
107 S RMPRPROS(2)=RMPROBL ; OBL#
108 ;
109DG1ZCL ; SET UP DATA FOR DG1 AND ZCL
110 S RMPRBA1=$G(^RMPR(660,RMPRDA,"BA1"))
111 S RMPRBA2=$G(^RMPR(660,RMPRDA,"BA2"))
112 S RMPRBA3=$G(^RMPR(660,RMPRDA,"BA3"))
113 S RMPRBA4=$G(^RMPR(660,RMPRDA,"BA4"))
114 S RMPRDIAG=$P($G(^RMPR(660,RMPRDA,10)),"^",8)
115 S RMPRICDT=$P(^RMPR(660,RMPRDA,0),"^")
116 F I=1:1:4 D
117 .; DG1
118 .;CSV CHECK
119 .S RMPRDRG=$P(@("RMPRBA"_I),"^")
120 .S:+RMPRDRG RMPRDRG=$$STATCHK^ICDAPIU($P($G(^ICD9(RMPRDRG,0)),"^"),RMPRICDT)
121 .Q:+RMPRDRG=0
122 .S RMPRDG1(I,3)=$P(RMPRDRG,"^",2) ; Diagnosis Code
123 .S RMPRDG1(I,6)="F" ; Diagnosis Type
124 .;
125 .; ZCL
126 .F J=2:1:8 I $P(@("RMPRBA"_I),"^",J)'="" D
127 ..; Set type and value. Overwrite null and zero values
128 ..S:+$G(RMPRZCL(J-1,3))=0 RMPRZCL(J-1,2)=J-1,RMPRZCL(J-1,3)=$P(@("RMPRBA"_I),"^",J)
129 ..Q
130 .Q
131 ; IF NO CONSULT DIAG, USE PROSTHETICS ONE
132 I $G(RMPRDG1(1,3))="" D
133 .S RMPRDRG=$$STATCHK^ICDAPIU($P($G(^ICD9(RMPRDIAG,0)),"^"),RMPRICDT)
134 .Q:+RMPRDRG=0
135 .S RMPRDG1(1,3)=$P(RMPRDRG,"^",2),RMPRDG1(1,6)="F"
136 .Q
137 Q
138 ;
139SENDCHRG ; Send Charge Data
140 S RMPRCHRG=""
141 S RMPRCHRG=$$CHARGE^IBBAPI(RMPRDFN,RMPRARFN,RMPRTYPE,RMPRUCID,.RMPRFT1,.RMPRPR1,.RMPRDG1,.RMPRZCL,"","",.RMPRPROS)
142 Q
143 ;
144UPDATE ; Update latest fields
145 L +^RMPR(660,RMPRDA)
146 ; Store updates 102-latest PSAS HCPCS; 103-latest QTY; 104-latest Total Cost;
147 ; 105-latest Ordering Provider
148 S DIE="^RMPR(660,",DA=RMPRDA
149 S DR="102////^S X=RMPRHCPC;103////^S X=RMPRQTY;104////^S X=RMPRTC;"
150 S DR=DR_"105////^S X=RMPRORD"
151 D ^DIE
152 L -^RMPR(660,RMPRDA)
153 K DA,DIE,DR
154 Q
155 ;
156EXIT ; Common exit point
157 K RMPRFLAG,RMPRQTY,RMPRTC,RMPRCHRG,RMPRUCID,RMPRDFN
158 K RMPRARFN,RMPRTYPE,RMPRFT1,RMPRPR1,RMPRCPT,RMPRRICP
159 K RMPRDG1,RMPRDIAG,RMPRZCL,RMPRNODE,RMPRPROS,RMPRHCPC
160 K RMRICPP,RMPRCPT
161 Q
Note: See TracBrowser for help on using the repository browser.