PSOCPTRI ;BHAM ISC/CPM,RTR - SUPPORT FOR CHAMPUS RX BILLING ;14-AUG-96
;;7.0;OUTPATIENT PHARMACY;**10,55,184,545**;DEC 1997;Build 270
;External reference to ^PSDRUG supported by DBIA 221
;
;
TRANS(ORIG,REF,PSOV) ; Extract Rx information for transmission to FI
; Input: ORIG -- Pointer to the rx in file #52
; REF -- Pointer to the refill in file #52.1
; (This is 0 if we are billing the original fill)
; PSOV -- Passed by reference. This array will be used
; to return the output (described below).
; Output: PSOE -- This is normally 1, or -1 if the NDC cannot
; be determined.
;
;
; Description of output variables to be passed to billing:
;
; PSOV("NDC") NDC # from the DRUG (#50) file
; PSOV("DIV") Pharmacy (in file #59) dispensing the rx
; PSOV("FDT") Rx Fill Date
; Last fill, field #101, or
; Dispensed, field #25
; PSOV("RX#") Prescription number, field #.01
; PSOV("QTY") Quantity, field #7
; PSOV("SUP") Days Supply, field #8
; PSOV("ISS") Issue Date, field #1
; PSOV("#REF") # Refills, field #9
; PSOV("COMP") 2 if manufactured in Pharmacy, else 1
; PSOV("DEA") DEA number from "PS" node in File 200
;
N PSOE,PSORX S PSOE=1
;
S PSORX(0)=$G(^PSRX(ORIG,0)),PSORX(2)=$G(^(2)),PSORX(3)=$G(^(3))
S:$G(REF) PSORX("REF")=$G(^PSRX(ORIG,1,REF,0))
I PSORX(0)="" S PSOE=-1 G TRANSQ
;
S PSOV("RX#")=$P(PSORX(0),"^") ; prescription number
; - first check for a valid NDC #
S PSOV("NDC")=$P($G(^PSDRUG(+$P(PSORX(0),"^",6),2)),"^",4)
I +PSOV("NDC")=0 S PSOE=-1 G TRANSQ
;
; - extract everything else
S PSOV("DIV")=$S($P($G(PSORX("REF")),"^",9):$P(PSORX("REF"),"^",9),1:$P(PSORX(2),"^",9)) ; pharmacy division
S PSOV("FDT")=$S($G(REF):$E($P(PSORX("REF"),"^"),1,7),1:$E($P(PSORX(2),"^",2),1,7))
I PSOV("FDT")="" S PSOV("FDT")=$S($P(PSORX(3),"^"):$P(PSORX(3),"^"),1:$P(PSORX(2),"^",5))
;
S PSOV("QTY")=$S($P($G(PSORX("REF")),"^",4)'="":$P(PSORX("REF"),"^",4),1:$P(PSORX(0),"^",7)) ; quantity
S PSOV("SUP")=$S($P($G(PSORX("REF")),"^",10)'="":$P(PSORX("REF"),"^",10),1:$P(PSORX(0),"^",8)) ; days supply
S PSOV("ISS")=$P(PSORX(0),"^",13) ; date rx written
S PSOV("#REF")=$P(PSORX(0),"^",9) ; # refills authorized
;
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
;
;*545 - get DEA#
S PSOV("DEA")=$S($P(PSORX(0),"^",4):$$GDEA(+$P(PSORX(0),"^",4)),1:"")
;
;
TRANSQ Q PSOE
;
;
LABEL(RX,PSOLAP,PSOSITE,DUZ,PSOTRAMT) ; Print the label.
; Input: RX -- Pointer to the prescription in file #52
; PSOLAP -- Label printer
; PSOSITE -- Pointer to the Pharmacy in file #59
; DUZ -- Pointer to the use in file #200
; PSOTRAMT -- Amount to be paid
;
;
Q:PSOLAP["LAT-TERM"
Q:'$D(^PSRX(RX,0))
Q:'$D(^PS(59,PSOSITE,0))
N CT,II,III,NOW,RXFF,X,Y,PSOSYS,PSOPAR,PSOBARS,PDUZ,PSOBAR0,PSOBAR1,REPRINT,PSOCHAMP,PSHRX,DIQUIET
S DIQUIET=1 D DT^DICRW
I '$G(DT) S DT=$$DT^XLFDT
S:$P($G(^PSRX(RX,"STA")),"^")'=3 REPRINT=""
D:$P($G(^PSRX(RX,"STA")),"^")=3
.S RXFF=0 F II=0:0 S II=$O(^PSRX(RX,1,II)) Q:'II S RXFF=II
.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
.S PSHRX=RX D EN^PSOHLSN1(RX,"OE","","Rx removed from CHAMPUS billing hold","A") S RX=PSHRX
.K ^PSRX("AH",+$P($G(^PSRX(RX,"H")),"^"),RX) S ^PSRX(DA,"H")=""
.D NOW^%DTC S NOW=%
.S III=0 F CT=0:0 S CT=$O(^PSRX(RX,"A",CT)) Q:'CT S III=CT
.S III=III+1,^PSRX(RX,"A",0)="^52.3DA^"_III_"^"_III
.S ^PSRX(RX,"A",III,0)=NOW_"^"_"U"_"^"_+$G(DUZ)_"^"_$S(RXFF<6:RXFF,1:(RXFF+1))_"^"_"Rx removed from CHAMPUS billing hold"
;
IO S %ZIS="",IOP=PSOLAP D ^%ZIS I POP H 5 G IO
N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
S PSOSYS=$G(^PS(59,PSOSITE,1))
S PSOPAR=$G(^PS(59,PSOSITE,1)),PDUZ=DUZ
S PPL=RX
S PSOCHAMP=1
S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&($P(PSOPAR,"^",19))
D DQ^PSOLBL
D ^%ZISC
;
Q
;
;
CHK(ORIG,REF) ; Should this rx be billed to the CHAMPUS Fiscal Intermediary?
; Input: ORIG -- Pointer to the rx in file #52
; REF -- Pointer to the refill in file #52.1, or
; 0 for the original fill
; Output: PSOB -- 0 => The rx should not be billed
; 1 => The rx may be billed.
;
N PSOB
;
; - ignore CHAMPUS billing for certain RX Patient Statuses
I $P($G(^PS(53,+$P($G(^PSRX(+$G(ORIG),0)),"^",3),0)),"^",8) G CHKQ
;
S PSOB=1
;
CHKQ Q +$G(PSOB)
;
DEV ;Get devices
N PSOTRION
S PSOTRION=ION
I $G(PSOLAP)]"",$G(PSOLAP)'=ION Q
DEVA 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
S PSOLAP=ION
N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&($P($G(PSOPAR),"^",10))
D ^%ZISC S ION=PSOTRION Q
;
EXM ;Edit Champus Billing Exemption field
I '$D(PSOPAR) D ^PSOLSET G EXM
W ! K DIC S DIC="^PS(53,",DIC(0)="AEQMZ" D ^DIC K DIC I Y<0!($D(DTOUT))!($D(DUOUT)) G EXMQ
W ! K DIE S DA=+Y,DIE="^PS(53,",DR=16 D ^DIE
EXMQ K DIE,DIC,Y
Q
RESDIR ;Reset DIR just in case
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 "
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"
S DIR("?",2)="Enter 'H' to hold label until Rx can be filled",DIR("?",3)="Enter 'P' for Rx profile"
S:$P(PSOPAR,"^",26) DIR("?",5)="Enter 'L' to print labels without queuing"
Q
;
GDEA(IEN) ; Get DEA number
N DEA
S DEA=$$DEA^XUSER(0,IEN) ;DBIA2343
Q DEA
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCPTRI 6232 printed Apr 09, 2024@21:32:50 Page 2
PSOCPTRI ;BHAM ISC/CPM,RTR - SUPPORT FOR CHAMPUS RX BILLING ;14-AUG-96
+1 ;;7.0;OUTPATIENT PHARMACY;**10,55,184,545**;DEC 1997;Build 270
+2 ;External reference to ^PSDRUG supported by DBIA 221
+3 ;
+4 ;
TRANS(ORIG,REF,PSOV) ; Extract Rx information for transmission to FI
+1 ; Input: ORIG -- Pointer to the rx in file #52
+2 ; REF -- Pointer to the refill in file #52.1
+3 ; (This is 0 if we are billing the original fill)
+4 ; PSOV -- Passed by reference. This array will be used
+5 ; to return the output (described below).
+6 ; Output: PSOE -- This is normally 1, or -1 if the NDC cannot
+7 ; be determined.
+8 ;
+9 ;
+10 ; Description of output variables to be passed to billing:
+11 ;
+12 ; PSOV("NDC") NDC # from the DRUG (#50) file
+13 ; PSOV("DIV") Pharmacy (in file #59) dispensing the rx
+14 ; PSOV("FDT") Rx Fill Date
+15 ; Last fill, field #101, or
+16 ; Dispensed, field #25
+17 ; PSOV("RX#") Prescription number, field #.01
+18 ; PSOV("QTY") Quantity, field #7
+19 ; PSOV("SUP") Days Supply, field #8
+20 ; PSOV("ISS") Issue Date, field #1
+21 ; PSOV("#REF") # Refills, field #9
+22 ; PSOV("COMP") 2 if manufactured in Pharmacy, else 1
+23 ; PSOV("DEA") DEA number from "PS" node in File 200
+24 ;
+25 NEW PSOE,PSORX
SET PSOE=1
+26 ;
+27 SET PSORX(0)=$GET(^PSRX(ORIG,0))
SET PSORX(2)=$GET(^(2))
SET PSORX(3)=$GET(^(3))
+28 if $GET(REF)
SET PSORX("REF")=$GET(^PSRX(ORIG,1,REF,0))
+29 IF PSORX(0)=""
SET PSOE=-1
GOTO TRANSQ
+30 ;
+31 ; prescription number
SET PSOV("RX#")=$PIECE(PSORX(0),"^")
+32 ; - first check for a valid NDC #
+33 SET PSOV("NDC")=$PIECE($GET(^PSDRUG(+$PIECE(PSORX(0),"^",6),2)),"^",4)
+34 IF +PSOV("NDC")=0
SET PSOE=-1
GOTO TRANSQ
+35 ;
+36 ; - extract everything else
+37 ; pharmacy division
SET PSOV("DIV")=$SELECT($PIECE($GET(PSORX("REF")),"^",9):$PIECE(PSORX("REF"),"^",9),1:$PIECE(PSORX(2),"^",9))
+38 SET PSOV("FDT")=$SELECT($GET(REF):$EXTRACT($PIECE(PSORX("REF"),"^"),1,7),1:$EXTRACT($PIECE(PSORX(2),"^",2),1,7))
+39 IF PSOV("FDT")=""
SET PSOV("FDT")=$SELECT($PIECE(PSORX(3),"^"):$PIECE(PSORX(3),"^"),1:$PIECE(PSORX(2),"^",5))
+40 ;
+41 ; quantity
SET PSOV("QTY")=$SELECT($PIECE($GET(PSORX("REF")),"^",4)'="":$PIECE(PSORX("REF"),"^",4),1:$PIECE(PSORX(0),"^",7))
+42 ; days supply
SET PSOV("SUP")=$SELECT($PIECE($GET(PSORX("REF")),"^",10)'="":$PIECE(PSORX("REF"),"^",10),1:$PIECE(PSORX(0),"^",8))
+43 ; date rx written
SET PSOV("ISS")=$PIECE(PSORX(0),"^",13)
+44 ; # refills authorized
SET PSOV("#REF")=$PIECE(PSORX(0),"^",9)
+45 ;
+46 ; Compound drug
NEW PSOX
SET PSOX=+$PIECE(PSORX(0),"^",6)
SET PSOV("COMP")=$PIECE($GET(^PSDRUG(PSOX,0)),"^",3)
SET PSOV("COMP")=$SELECT(PSOV("COMP")[0:2,1:1)
+47 ;
+48 ;*545 - get DEA#
+49 SET PSOV("DEA")=$SELECT($PIECE(PSORX(0),"^",4):$$GDEA(+$PIECE(PSORX(0),"^",4)),1:"")
+50 ;
+51 ;
TRANSQ QUIT PSOE
+1 ;
+2 ;
LABEL(RX,PSOLAP,PSOSITE,DUZ,PSOTRAMT) ; Print the label.
+1 ; Input: RX -- Pointer to the prescription in file #52
+2 ; PSOLAP -- Label printer
+3 ; PSOSITE -- Pointer to the Pharmacy in file #59
+4 ; DUZ -- Pointer to the use in file #200
+5 ; PSOTRAMT -- Amount to be paid
+6 ;
+7 ;
+8 if PSOLAP["LAT-TERM"
QUIT
+9 if '$DATA(^PSRX(RX,0))
QUIT
+10 if '$DATA(^PS(59,PSOSITE,0))
QUIT
+11 NEW CT,II,III,NOW,RXFF,X,Y,PSOSYS,PSOPAR,PSOBARS,PDUZ,PSOBAR0,PSOBAR1,REPRINT,PSOCHAMP,PSHRX,DIQUIET
+12 SET DIQUIET=1
DO DT^DICRW
+13 IF '$GET(DT)
SET DT=$$DT^XLFDT
+14 if $PIECE($GET(^PSRX(RX,"STA")),"^")'=3
SET REPRINT=""
+15 if $PIECE($GET(^PSRX(RX,"STA")),"^")=3
Begin DoDot:1
+16 SET RXFF=0
FOR II=0:0
SET II=$ORDER(^PSRX(RX,1,II))
if 'II
QUIT
SET RXFF=II
+17 KILL DIE
SET DIE="^PSRX("
SET DA=RX
SET DR=$SELECT('RXFF:"22///"_DT_";",1:"")_"100///"_0_";101///"_$SELECT('RXFF:DT,1:+$PIECE($GET(^PSRX(RX,1,+$GET(RXFF),0)),"^"))
DO ^DIE
KILL DIE
+18 SET PSHRX=RX
DO EN^PSOHLSN1(RX,"OE","","Rx removed from CHAMPUS billing hold","A")
SET RX=PSHRX
+19 KILL ^PSRX("AH",+$PIECE($GET(^PSRX(RX,"H")),"^"),RX)
SET ^PSRX(DA,"H")=""
+20 DO NOW^%DTC
SET NOW=%
+21 SET III=0
FOR CT=0:0
SET CT=$ORDER(^PSRX(RX,"A",CT))
if 'CT
QUIT
SET III=CT
+22 SET III=III+1
SET ^PSRX(RX,"A",0)="^52.3DA^"_III_"^"_III
+23 SET ^PSRX(RX,"A",III,0)=NOW_"^"_"U"_"^"_+$GET(DUZ)_"^"_$SELECT(RXFF<6:RXFF,1:(RXFF+1))_"^"_"Rx removed from CHAMPUS billing hold"
End DoDot:1
+24 ;
IO SET %ZIS=""
SET IOP=PSOLAP
DO ^%ZIS
IF POP
HANG 5
GOTO IO
+1 NEW PSOIOS
SET PSOIOS=IOS
DO DEVBAR^PSOBMST
+2 SET PSOSYS=$GET(^PS(59,PSOSITE,1))
+3 SET PSOPAR=$GET(^PS(59,PSOSITE,1))
SET PDUZ=DUZ
+4 SET PPL=RX
+5 SET PSOCHAMP=1
+6 SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&($PIECE(PSOPAR,"^",19))
+7 DO DQ^PSOLBL
+8 DO ^%ZISC
+9 ;
+10 QUIT
+11 ;
+12 ;
CHK(ORIG,REF) ; Should this rx be billed to the CHAMPUS Fiscal Intermediary?
+1 ; Input: ORIG -- Pointer to the rx in file #52
+2 ; REF -- Pointer to the refill in file #52.1, or
+3 ; 0 for the original fill
+4 ; Output: PSOB -- 0 => The rx should not be billed
+5 ; 1 => The rx may be billed.
+6 ;
+7 NEW PSOB
+8 ;
+9 ; - ignore CHAMPUS billing for certain RX Patient Statuses
+10 IF $PIECE($GET(^PS(53,+$PIECE($GET(^PSRX(+$GET(ORIG),0)),"^",3),0)),"^",8)
GOTO CHKQ
+11 ;
+12 SET PSOB=1
+13 ;
CHKQ QUIT +$GET(PSOB)
+1 ;
DEV ;Get devices
+1 NEW PSOTRION
+2 SET PSOTRION=ION
+3 IF $GET(PSOLAP)]""
IF $GET(PSOLAP)'=ION
QUIT
DEVA WRITE !
SET %ZIS("B")=""
SET %ZIS="MNQ"
SET %ZIS("A")="Select LABEL DEVICE: "
DO ^%ZIS
IF POP!($EXTRACT(IOST)'["P")
WRITE !,"Label Printer device must be selected!",!
GOTO DEVA
+1 SET PSOLAP=ION
+2 NEW PSOIOS
SET PSOIOS=IOS
DO DEVBAR^PSOBMST
+3 SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&($PIECE($GET(PSOPAR),"^",10))
+4 DO ^%ZISC
SET ION=PSOTRION
QUIT
+5 ;
EXM ;Edit Champus Billing Exemption field
+1 IF '$DATA(PSOPAR)
DO ^PSOLSET
GOTO EXM
+2 WRITE !
KILL DIC
SET DIC="^PS(53,"
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
IF Y<0!($DATA(DTOUT))!($DATA(DUOUT))
GOTO EXMQ
+3 WRITE !
KILL DIE
SET DA=+Y
SET DIE="^PS(53,"
SET DR=16
DO ^DIE
EXMQ KILL DIE,DIC,Y
+1 QUIT
RESDIR ;Reset DIR just in case
+1 SET DIR("A")="LABEL: QUEUE"_$SELECT($PIECE(PSOPAR,"^",23):"/HOLD",1:"")_$SELECT($PIECE(PSOPAR,"^",24):"/SUSPEND",1:"")_$SELECT($PIECE(PSOPAR,"^",26):"/LABEL",1:"")_" or '^' to bypass "
+2 SET DIR("?",1)="Enter 'Q' to queue labels to print"
SET DIR("?")="Enter '^' to bypass label functions"
SET DIR("?",4)="Enter 'S' to suspend labels to print later"
+3 SET DIR("?",2)="Enter 'H' to hold label until Rx can be filled"
SET DIR("?",3)="Enter 'P' for Rx profile"
+4 if $PIECE(PSOPAR,"^",26)
SET DIR("?",5)="Enter 'L' to print labels without queuing"
+5 QUIT
+6 ;
GDEA(IEN) ; Get DEA number
+1 NEW DEA
+2 ;DBIA2343
SET DEA=$$DEA^XUSER(0,IEN)
+3 QUIT DEA
+4 ;
