source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPF3.m

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

initial load of FOIAVistA 6/30/08 version

File size: 2.7 KB
Line 
1RMPRPF3 ;HOIFO/TH,DDA - PFSS Charge Cancel (credit) ;8/18/05
2 ;;3.0;PROSTHETICS;**98**;Feb 09, 1996
3 ;
4 ; This routine sends "Credit" Charge Message to IBB if .01 field got deleted in file 660
5 ; or if the PSAS HCPCS code is deleted (equals null after user edit).
6 ;
7 ; DBIA # 4663 for SWSTAT^IBBAPI
8 ; DBIA # 4665 for CHARGE^IBBAPI
9 Q
10 ;
11CHRGTASK ; FILE #660, ENTRY DATE AND PSAS HCPCS FIELDS MUMPS XREF
12 ;KILL LOGIC.
13 ; TASKMAN LOAD A ONE TIME TASKMAN TASK.
14 ; QUIT IF PFSS SWITCH IS OFF OR IF THERE IS NO CHARGE TO REVERSE
15 Q:'+$$SWSTAT^IBBAPI()
16 S RMPRPFSS=$G(^RMPR(660,DA,"PFSS"))
17 Q:$P(RMPRPFSS,"^",2)=""
18 S RMPRZERO=^RMPR(660,DA,0)
19 N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC
20 S ZTIO="",ZTRTN="CHRGCRED^RMPRPF3",ZTDESC="Prosthetics file #660 PFSS Charge Credit",ZTDTH=$H
21 S ZTSAVE("RMPRIEN")=DA
22 S ZTSAVE("RMPRZERO")=RMPRZERO
23 S ZTSAVE("RMPRONE")=$G(^RMPR(660,DA,1))
24 S ZTSAVE("RMPRTEN")=$G(^RMPR(660,DA,10))
25 S ZTSAVE("RMPRPFSS")=RMPRPFSS
26 D ^%ZTLOAD
27 Q
28 ;
29CHRGCRED ; Process account deletion/cancellation
30 ;
31 ; Check if already processing this record.
32 Q:$G(^TMP("RMPRPF3",RMPRIEN))=RMPRIEN
33 S ^TMP("RMPRPF3",RMPRIEN)=RMPRIEN
34 ; Check if this is just a Date edit or a PSAS HCPCS edit, set x-ref AND QUIT.
35 S RMPRCDFL=0
36 S:'$D(^RMPR(660,RMPRIEN,0)) RMPRCDFL=1
37 S:$P($G(RMPRONE),"^",4)="" RMPRCDFL=1
38 I RMPRCDFL=0 D SETAPD G EXIT
39 ; RECORD HAS EITHER BEEN DELETED OR PSAS HCPCS HAS BEEN DELETED. SEND A CREDIT (CD).
40 S RMPRUCID=$P(RMPRPFSS,U,2)
41 S RMPRTYPE="CD"
42 S RMPRDFN=$P(RMPRZERO,"^",2)
43 S RMPRARFN=$P(RMPRPFSS,"^")
44 ;
45 ; FT1
46 S RMPRFT1(4)=$P(RMPRZERO,"^",12) ; Delivery Date
47 S RMPRFT1(10)=$P(RMPRZERO,"^",7) ; Transaction Quantity
48 S RMPRFT1(13)=423 ; Department Code
49 S RMPRFT1(21)=$P($G(RMPRTEN),"^",6) ; Ordering Provider/Ordered by Code
50 S RMPRTC=$P(RMPRZERO,"^",16)
51 S RMPRFT1(22)=RMPRTC/RMPRFT1(10) ; Unit Cost = Total Cost/QTY
52 ; PR1
53 S RMPRHCPC=$P(RMPRONE,"^",4)
54 S RMPRHCDT=$P(RMPRONE,"^")
55 D PSASHCPC^RMPOPF
56 S RMPRPR1(3)=RMPRVHC ; Procedure Code
57 S RMPRPR1(4)=RMPRTHC ; PSAS HCPCS text
58 ; Procedure Functional Type - I:Stock Issue;P:Purchasing
59 S RMPRPR1(6)=$S($P(RMPRZERO,"^",13)=11:"I",1:"P")
60 ;
61SENDDATA ; Send charge data
62 S RMPRCHRG=$$CHARGE^IBBAPI(RMPRDFN,RMPRARFN,RMPRTYPE,RMPRUCID,.RMPRFT1,.RMPRPR1,"","","","","")
63 Q
64 ;
65SETAPD ; Set the APD cross-reference because the activity was only an edit, not a delete.
66 S DIE="^RMPR(660,"
67 S DA=RMPRIEN
68 S DR="107///^S X=1"
69 D ^DIE
70 K DIE,DA,DR
71 Q
72EXIT ; Common exit point
73 K ^TMP("RMPRPF3",RMPRIEN)
74 K RMPRQTY,RMPRTC,RMPRCHRG,RMPRUCID,RMPRDFN,RMRICPP,RMPRCPT
75 K RMPRARFN,RMPRTYPE,RMPRFT1,RMPRPR1,RMPRCPT,RMPRRICP
76 K RMPRDG1,RMPRDIAG,RMPRZCL,RMPRNODE,RMPRPROS,RMPRHCPC,RMPRHCDT,RMPRVHC,RMPRTHC
77 K ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC
78 Q
Note: See TracBrowser for help on using the repository browser.