source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOPF1.m@ 784

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

initial load of FOIAVistA 6/30/08 version

File size: 2.9 KB
Line 
1RMPOPF1 ;HINES-FO/DDA - (CONT.)MAIN INTERFACE ROUTINE FOR PFSS AND HOME OXYGEN ;8/18/05
2 ;;3.0;PROSTHETICS;**98**;Feb 09, 1996
3 Q
4CHARGE ; Called from RMPOPST3 via CHARGE^RMPOPF
5 ;IMPORTANT VARIBLES PASSED IN FROM RMPOPST3
6 ; D6I= FILE 660 IEN
7 ; RMPOXITE= FILE 665.72 SITE (IEN)
8 ; RMPODATE= FILE 665.72 BILLING MONTH mult IEN
9 ; RMPOVDR= FILE 665.72 VENDOR mult IEN (DINUM to 440)
10 ; DFN= FILE 665.72 PATIENT mult IEN (DINUM to 2)
11 ; ITM= FILE 665.72 ITEM mult IEN
12 ; TRXDT= Date TRX Built
13 ; ITMD= Item multiple zero node
14 ;
15 ;Set variables
16 S RMPRDFN=DFN
17 S RMPRITEM=0
18 S RMPRITEM=$O(^RMPR(665,DFN,"RMPOC","B",$P(ITMD,"^"),RMPRITEM))
19 S RMPRPAR=$P($G(^RMPR(665,RMPRDFN,"RMPOC",RMPRITEM,"PFSS")),"^",2)
20 S RMPRTYPE="CG"
21 S RMPRFT1(4)=TRXDT
22 S RMPRFT1(10)=$P(ITMD,"^",7)
23 S RMPRFT1(13)=423
24 S RMPRSTA=RMPOXITE
25 D GETSITE^RMPRPF1
26 S RMPRFT1(16)=RMPRHLOC
27 S RMPRIEN=DFN D VALIDRX^RMPOPF K RMPRIEN
28 S RMPRFT1(21)=$P($G(^RMPR(665,DFN,"RMPOB",RMPRRXI,"PFSS")),"^",2)
29 S RMPRFT1(22)=$P(ITMD,"^",5)
30 S RMPRHCPC=$P(ITMD,"^",2)
31 S RMPRHCDT=TRXDT
32 ; INSURE HCPCS IS CODE SET VERSIONED
33 D PSASHCPC^RMPOPF
34 S RMPRPR1(3)=RMPRVHC
35 S RMPRPR1(4)=RMPRTHC
36 S RMPRPR1(6)="O"
37 ; INSURE ICD9 IS CODE SET VERSIONED
38 S RMPRDRG=$P(ITMD,"^",9)
39 S:RMPRDRG'="" RMPRDRG=$$STATCHK^ICDAPIU($P($G(^ICD9(RMPRDRG,0)),"^"),TRXDT)
40 S:$P(RMPRDRG,"^")=1 RMPRDG1(1,3)=$P(RMPRDRG,"^",2),RMPRDG1(1,6)="F"
41 S RMPRZCL=""
42 S RMPRPROS(1)=RMPOVDR
43 S RMPRUCID=$P($G(^RMPO(665.72,RMPOXITE,1,RMPODATE,1,RMPOVDR,"V",DFN,1,ITM,"PFSS")),"^",2)
44 S:RMPRUCID'>0 RMPRUCID=$$GETCHGID^IBBAPI()
45 S RMPRFLAG=$$CHARGE^IBBAPI(RMPRDFN,RMPRPAR,RMPRTYPE,RMPRUCID,.RMPRFT1,.RMPRPR1,.RMPRDG1,.RMPRZCL,"","",.RMPRPROS)
46 Q:RMPRFLAG=0
47 ;STORE RETURN INFO INTO 665.72
48 S DA=ITM,DA(1)=DFN,DA(2)=RMPOVDR,DA(3)=RMPODATE,DA(4)=RMPOXITE
49 S DIE="^RMPO(665.72,"_DA(4)_",1,"_DA(3)_",1,"_DA(2)_",""V"","_DA(1)_",1,"
50 S DR="100///"_RMPRPAR_";101///"_RMPRUCID_";102///"_RMPRFT1(21)
51 D ^DIE
52 K DA,DIE,DR
53 ;STORE RETURN INFO INTO 660
54 S DA=D6I
55 S DIE="^RMPR(660,"
56 S DR="100///"_RMPRPAR_";101///"_RMPRUCID_";102///"_$P($G(^RMPR(660,D6I,1)),"^",4)_";103///"_$P($G(^RMPR(660,D6I,0)),"^",7)_";104///"_$P($G(^RMPR(660,D6I,0)),"^",16)_";106///@;107///@"
57 D ^DIE
58 K DA,DIE,DR
59 ;
60 K RMPRDFN,RMPRDG1,RMPRDRG,RMPRFLAG,RMPRFT1,RMPRHCPC,RMPRHLOC,RMPRITEM,RMPRPAR,RMPRPR1,RMPRPROS,RMPRRXDT,RMPRRXI,RMPRSTA,RMPRSTAT,RMPRTYPE,RMPRUCID
61 Q
62CHRGCRED ; Called when an previously charged item is deleted from 665.72
63 ; Variables passed in via TaskMan
64 ; RMPRSITE = 665.72 IEN - SITE
65 ; RMPRBLDT = 665.723;1 - BILLING MONTH IEN
66 ; RMPRVDR = 665.7231;1 - VENDOR IEN (DINUM 440)
67 ; RMPRDFN = 665.72319;9 - PATIENT IEN (DINUM 200)
68 ; RMPRITEM = 665.723191 - ITEM IEN
69 ; RMPRPFSS = DATA FROM THE ITEM'S "PFSS" NODE
70 ;
71 ;Quit if item data still exists
72 Q:$D(^RMPO(665.72,RMPRSITE,1,RMPRBLDT,1,RMPRVDR,"V",RMPRDFN,1,RMPRITEM,0))
73 S RMPRFLAG=$$CHARGE^IBBAPI(RMPRDFN,$P(RMPRPFSS,"^",1),"CD",$P(RMPRPFSS,"^",2))
74 K RMPRBLDT,RMPRDFN,RMPRFLAG,RMPRITEM,RMPRPFSS,RMPRSITE,RMPRVDR
75 Q
Note: See TracBrowser for help on using the repository browser.