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

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

initial load of WorldVistAEHR
File size: 4.5 KB
Line 
1IBECUS21 ;RLM/DVAMC - FILE TRICARE PHARMACY TRANSACTIONS ; 14-AUG-96
2 ;;2.0;INTEGRATED BILLING;**52,240,274**;21-MAR-94
3 ;
4TRAN ; File a Pharmacy Billing transaction in file #351.5.
5 ; Input: DFN -- Pointer to the patient in file #2
6 ; IBLINE -- Array of data transmitted to the FI
7 ; IBRESP -- Array of data received from the FI
8 ; IBKEY -- 1 ; 2, where
9 ; 1 = Pointer to the prescription in file #52
10 ; 2 = Pointer to the refill in file #52.1, or
11 ; 0 for the original fill
12 ; IBKEYD -- 1 ^ 2 ^ 3 ^ 4, where
13 ; 1 = Rx label printing device
14 ; 2 = Pointer to the Pharmacy in file #59
15 ; 3 = Pointer to the Pharmacy user in file #200
16 ; 4 = Pointer to the billing transaction
17 ; in file #351.5 (cancellations only)
18 ;
19 ; - don't process duplicate transactions
20 I $E(IBRESP(1),17)="D" Q
21 ;
22 ; - find transaction entry or create a new one
23 S IBCHTRN=$O(^IBA(351.5,"B",IBKEY,0))
24 I 'IBCHTRN D
25 .S I=$P(^IBA(351.5,0),"^",3)
26 .F S I=I+1 L +^IBA(351.5,I):1 Q:$T&'$D(^IBA(351.5,I)) L -^IBA(351.5,I)
27 .S ^IBA(351.5,I,0)=IBKEY,^IBA(351.5,"B",IBKEY,I)=""
28 .S ^IBA(351.5,0)=$P(^IBA(351.5,0),"^",1,2)_"^"_I_"^"_($P(^IBA(351.5,0),"^",4)+1)
29 .S IBCHTRN=I L -^IBA(351.5,IBCHTRN)
30 ;
31 ; - prepare i/o for filing
32 S IBPROC("I")="" F IBI=1:1:2 S IBPROC("I")=IBPROC("I")_$G(IBRESP(IBI))
33 S IBPROC("O")="" F IBI=1:1:5 S IBPROC("O")=IBPROC("O")_$G(IBLINE(IBI))
34 S IBPROC("O")=$E(IBPROC("O"),3,999)
35 ;
36 ; - file transaction data
37 S $P(^IBA(351.5,IBCHTRN,0),"^",2,6)=DFN_"^"_$P(IBCDFND,"^",2)_"^"_$TR(IBDRX("NDC"),"-","")_"^"_$J((+IBUAC/100),0,2)_"^"_IBDRX("QTY")
38 F IBI=1:1 S IBTABLE=$T(TABLE+IBI) Q:$P(IBTABLE,";",3)="$END" D
39 .Q:$P(IBTABLE,";",4)<2
40 .;
41 .; - file only the 0th node for rejects
42 .I $E(IBRESP(1),17)="R",$P(IBTABLE,";",4)>1 Q
43 .;
44 .S X="" I $P(IBTABLE,";",6)'?1.N X $P(IBTABLE,";",6)
45 .I X="" S X=$E(IBPROC($P(IBTABLE,";",3)),$P(IBTABLE,";",6),$P(IBTABLE,";",7))
46 .I $P(IBTABLE,";",2)["D" Q:'X D DOLLAR
47 .;
48 .; - file each field individually
49 .I X]"" S $P(^IBA(351.5,IBCHTRN,$P(IBTABLE,";",4)),"^",$P(IBTABLE,";",5))=X
50 ;
51 ; - delete cancellation authorization number
52 S $P(^IBA(351.5,IBCHTRN,6),"^")=""
53 ;
54 ; - handle rejects, update transaction date and cross reference
55 D REJECT
56 N DIQUIET S DIQUIET=1 D DT^DICRW S $P(^IBA(351.5,IBCHTRN,0),U,7)=DT
57 S DA=IBCHTRN,DIK="^IBA(351.5," D IX^DIK
58 Q
59 ;
60 ;
61DOLLAR ; Convert cents to dollars.
62 S X=$E(X,1,($L(X)-2))_"."_$E(X,($L(X)-1),$L(X))
63 F Q:$E(X,1)'=0 S X=$E(X,2,999)
64 Q
65 ;
66 ;
67REJECT ; Act on billing rejects.
68 ;
69 ; - file reject information
70 S IBREJ="" I $E(IBRESP(1),17)="R" D
71 .F IBJ=20:2 S IBJA=$E(IBRESP(1),IBJ,IBJ+1) Q:IBJA=" "!(IBJA="") D
72 ..S IBERRP=$$ERRIEN^IBECUS22("UNIVERSAL",IBJA)
73 ..I IBERRP S IBREJ=IBREJ_","_IBERRP
74 S:$L(IBREJ) IBREJ=$E(IBREJ,2,999)
75 S ^IBA(351.5,IBCHTRN,5)=IBREJ
76 ;
77 ; - if the transaction was not rejected, delete the existing
78 ; reject entry if it exists
79 S IBCHREJ=$O(^IBA(351.52,"B",IBKEY,0))
80 I IBREJ="" D G REJECTQ
81 .I IBCHREJ S DA=IBCHREJ,DIK="^IBA(351.52," D ^DIK K DA,DIK
82 ;
83 ; - add a new reject entry if necessary
84 I 'IBCHREJ D ADDREJ
85 ;
86 ; - update reject file
87 S DA=IBCHTRN,DIE="^IBA(351.52,",DR=".02////"_IBCHTRN_";.03////"_DT
88 D ^DIE K DA,DIE,DR
89 S ^IBA(351.52,IBCHREJ,1)=IBREJ
90 ;
91 ; - generate a reject alert
92 S XQA("G.IB CHAMP RX REJ")="",XQA(+$P(IBKEYD,"^",3))=""
93 S XQAMSG="Prescription #"_IBDRX("RX#")_" rejected for reason #"_IBREJ
94 S XQADATA=IBDRX("RX#")_"^"_IBREJ_"^"_DFN,XQAROU="DISP^IBECUS22"
95 D SETUP^XQALERT
96 ;
97 ; - remove prescription from queue
98 I $P($G(^IBE(351.51,+IBREJ,0)),"^",2)<89 K ^IBA(351.5,"APOST",IBKEY)
99REJECTQ Q
100 ;
101 ;
102ADDREJ ; Add stub entry to the Reject file.
103 S I=$P(^IBA(351.52,0),"^",3)
104 F S I=I+1 L +^IBA(351.52,I):1 Q:$T&'$D(^IBA(351.52,I)) L -^IBA(351.52,I)
105 S ^IBA(351.52,I,0)=IBKEY,^IBA(351.52,"B",IBKEY,I)=""
106 S ^IBA(351.52,0)=$P(^IBA(351.52,0),"^",1,2)_"^"_I_"^"_($P(^IBA(351.52,0),"^",4)+1)
107 S IBCHREJ=I L -^IBA(351.52,I)
108 Q
109 ;
110 ;
111TABLE ; Table of field positions and file locations in file #351.5.
112 ;;O;0;2;S X=DFN
113 ;;O;0;3;48;65
114 ;;O;0;4;268;278
115 ;D;O;0;5;280;285
116 ;;O;0;6;259;263
117 ;D;I;2;1;18;23
118 ;D;I;2;2;24;29
119 ;D;I;2;3;30;35
120 ;D;I;2;4;36;41
121 ;D;I;2;5;42;47
122 ;;I;2;6;48;61
123 ;;I;2;7;62;101
124 ;D;I;3;1;102;109
125 ;D;I;3;2;110;117
126 ;D;I;3;3;118;125
127 ;D;I;3;4;126;131
128 ;D;I;3;5;132;137
129 ;D;I;3;6;138;143
130 ;D;I;3;7;144;149
131 ;D;I;3;8;150;155
132 ;;I;3;9;156;157
133 ;D;I;3;10;158;163
134 ;;I;7;1;164;323
135 ;;I;8;1;324;403
136 ;;$END
Note: See TracBrowser for help on using the repository browser.