source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPTRI.m@ 1452

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

initial load of FOIAVistA 6/30/08 version
File size: 5.9 KB
Line 
1PSOCPTRI ;BHAM ISC/CPM,RTR - SUPPORT FOR CHAMPUS RX BILLING ;14-AUG-96
2 ;;7.0;OUTPATIENT PHARMACY;**10,55,184**;DEC 1997
3 ;External reference to ^PSDRUG supported by DBIA 221
4 ;
5 ;
6TRANS(ORIG,REF,PSOV) ; Extract Rx information for transmission to FI
7 ; Input: ORIG -- Pointer to the rx in file #52
8 ; REF -- Pointer to the refill in file #52.1
9 ; (This is 0 if we are billing the original fill)
10 ; PSOV -- Passed by reference. This array will be used
11 ; to return the output (described below).
12 ; Output: PSOE -- This is normally 1, or -1 if the NDC cannot
13 ; be determined.
14 ;
15 ;
16 ; Description of output variables to be passed to billing:
17 ;
18 ; PSOV("NDC") NDC # from the DRUG (#50) file
19 ; PSOV("DIV") Pharmacy (in file #59) dispensing the rx
20 ; PSOV("FDT") Rx Fill Date
21 ; Last fill, field #101, or
22 ; Dispensed, field #25
23 ; PSOV("RX#") Prescription number, field #.01
24 ; PSOV("QTY") Quantity, field #7
25 ; PSOV("SUP") Days Supply, field #8
26 ; PSOV("ISS") Issue Date, field #1
27 ; PSOV("#REF") # Refills, field #9
28 ; PSOV("COMP") 2 if manufactured in Pharmacy, else 1
29 ; PSOV("DEA") DEA number from "PS" node in File 200
30 ;
31 N PSOE,PSORX S PSOE=1
32 ;
33 S PSORX(0)=$G(^PSRX(ORIG,0)),PSORX(2)=$G(^(2)),PSORX(3)=$G(^(3))
34 S:$G(REF) PSORX("REF")=$G(^PSRX(ORIG,1,REF,0))
35 I PSORX(0)="" S PSOE=-1 G TRANSQ
36 ;
37 S PSOV("RX#")=$P(PSORX(0),"^") ; prescription number
38 ; - first check for a valid NDC #
39 S PSOV("NDC")=$P($G(^PSDRUG(+$P(PSORX(0),"^",6),2)),"^",4)
40 I +PSOV("NDC")=0 S PSOE=-1 G TRANSQ
41 ;
42 ; - extract everything else
43 S PSOV("DIV")=$S($P($G(PSORX("REF")),"^",9):$P(PSORX("REF"),"^",9),1:$P(PSORX(2),"^",9)) ; pharmacy division
44 S PSOV("FDT")=$S($G(REF):$E($P(PSORX("REF"),"^"),1,7),1:$E($P(PSORX(2),"^",2),1,7))
45 I PSOV("FDT")="" S PSOV("FDT")=$S($P(PSORX(3),"^"):$P(PSORX(3),"^"),1:$P(PSORX(2),"^",5))
46 ;
47 S PSOV("QTY")=$S($P($G(PSORX("REF")),"^",4)'="":$P(PSORX("REF"),"^",4),1:$P(PSORX(0),"^",7)) ; quantity
48 S PSOV("SUP")=$S($P($G(PSORX("REF")),"^",10)'="":$P(PSORX("REF"),"^",10),1:$P(PSORX(0),"^",8)) ; days supply
49 S PSOV("ISS")=$P(PSORX(0),"^",13) ; date rx written
50 S PSOV("#REF")=$P(PSORX(0),"^",9) ; # refills authorized
51 ;
52 N PSOX S PSOX=+$P(PSORX(0),"^",6) S PSOV("COMP")=$P($G(^PSDRUG(PSOX,0)),"^",3) S PSOV("COMP")=$S(PSOV("COMP")[0:2,1:1) ; Compound drug
53 ;
54 S PSOV("DEA")=$S($P(PSORX(0),"^",4):$P($G(^VA(200,$P(PSORX(0),"^",4),"PS")),"^",2),1:"") ; DEA #
55 ;
56 ;
57TRANSQ Q PSOE
58 ;
59 ;
60LABEL(RX,PSOLAP,PSOSITE,DUZ,PSOTRAMT) ; Print the label.
61 ; Input: RX -- Pointer to the prescription in file #52
62 ; PSOLAP -- Label printer
63 ; PSOSITE -- Pointer to the Pharmacy in file #59
64 ; DUZ -- Pointer to the use in file #200
65 ; PSOTRAMT -- Amount to be paid
66 ;
67 ;
68 Q:PSOLAP["LAT-TERM"
69 Q:'$D(^PSRX(RX,0))
70 Q:'$D(^PS(59,PSOSITE,0))
71 N CT,II,III,NOW,RXFF,X,Y,PSOSYS,PSOPAR,PSOBARS,PDUZ,PSOBAR0,PSOBAR1,REPRINT,PSOCHAMP,PSHRX,DIQUIET
72 S DIQUIET=1 D DT^DICRW
73 I '$G(DT) S DT=$$DT^XLFDT
74 S:$P($G(^PSRX(RX,"STA")),"^")'=3 REPRINT=""
75 D:$P($G(^PSRX(RX,"STA")),"^")=3
76 .S RXFF=0 F II=0:0 S II=$O(^PSRX(RX,1,II)) Q:'II S RXFF=II
77 .K DIE S DIE="^PSRX(",DA=RX,DR=$S('RXFF:"22///"_DT_";",1:"")_"100///"_0_";101///"_$S('RXFF:DT,1:+$P($G(^PSRX(RX,1,+$G(RXFF),0)),"^")) D ^DIE K DIE
78 .S PSHRX=RX D EN^PSOHLSN1(RX,"OE","","Rx removed from CHAMPUS billing hold","A") S RX=PSHRX
79 .K ^PSRX("AH",+$P($G(^PSRX(RX,"H")),"^"),RX) S ^PSRX(DA,"H")=""
80 .D NOW^%DTC S NOW=%
81 .S III=0 F CT=0:0 S CT=$O(^PSRX(RX,"A",CT)) Q:'CT S III=CT
82 .S III=III+1,^PSRX(RX,"A",0)="^52.3DA^"_III_"^"_III
83 .S ^PSRX(RX,"A",III,0)=NOW_"^"_"U"_"^"_+$G(DUZ)_"^"_$S(RXFF<6:RXFF,1:(RXFF+1))_"^"_"Rx removed from CHAMPUS billing hold"
84 ;
85IO S %ZIS="",IOP=PSOLAP D ^%ZIS I POP H 5 G IO
86 N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
87 S PSOSYS=$G(^PS(59,PSOSITE,1))
88 S PSOPAR=$G(^PS(59,PSOSITE,1)),PDUZ=DUZ
89 S PPL=RX
90 S PSOCHAMP=1
91 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&($P(PSOPAR,"^",19))
92 D DQ^PSOLBL
93 D ^%ZISC
94 ;
95 Q
96 ;
97 ;
98CHK(ORIG,REF) ; Should this rx be billed to the CHAMPUS Fiscal Intermediary?
99 ; Input: ORIG -- Pointer to the rx in file #52
100 ; REF -- Pointer to the refill in file #52.1, or
101 ; 0 for the original fill
102 ; Output: PSOB -- 0 => The rx should not be billed
103 ; 1 => The rx may be billed.
104 ;
105 N PSOB
106 ;
107 ; - ignore CHAMPUS billing for certain RX Patient Statuses
108 I $P($G(^PS(53,+$P($G(^PSRX(+$G(ORIG),0)),"^",3),0)),"^",8) G CHKQ
109 ;
110 S PSOB=1
111 ;
112CHKQ Q +$G(PSOB)
113 ;
114DEV ;Get devices
115 N PSOTRION
116 S PSOTRION=ION
117 I $G(PSOLAP)]"",$G(PSOLAP)'=ION Q
118DEVA W ! S %ZIS("B")="",%ZIS="MNQ",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS I POP!($E(IOST)'["P") W !,"Label Printer device must be selected!",! G DEVA
119 S PSOLAP=ION
120 N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
121 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&($P($G(PSOPAR),"^",10))
122 D ^%ZISC S ION=PSOTRION Q
123 ;
124EXM ;Edit Champus Billing Exemption field
125 I '$D(PSOPAR) D ^PSOLSET G EXM
126 W ! K DIC S DIC="^PS(53,",DIC(0)="AEQMZ" D ^DIC K DIC I Y<0!($D(DTOUT))!($D(DUOUT)) G EXMQ
127 W ! K DIE S DA=+Y,DIE="^PS(53,",DR=16 D ^DIE
128EXMQ K DIE,DIC,Y
129 Q
130RESDIR ;Reset DIR just in case
131 S DIR("A")="LABEL: QUEUE"_$S($P(PSOPAR,"^",23):"/HOLD",1:"")_$S($P(PSOPAR,"^",24):"/SUSPEND",1:"")_$S($P(PSOPAR,"^",26):"/LABEL",1:"")_" or '^' to bypass "
132 S DIR("?",1)="Enter 'Q' to queue labels to print",DIR("?")="Enter '^' to bypass label functions",DIR("?",4)="Enter 'S' to suspend labels to print later"
133 S DIR("?",2)="Enter 'H' to hold label until Rx can be filled",DIR("?",3)="Enter 'P' for Rx profile"
134 S:$P(PSOPAR,"^",26) DIR("?",5)="Enter 'L' to print labels without queuing"
135 Q
Note: See TracBrowser for help on using the repository browser.