- 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 Feb 18, 2025@23:52:31 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 ;