Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOCPTRI

PSOCPTRI.m

Go to the documentation of this file.
  1. 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
  1. ;External reference to ^PSDRUG supported by DBIA 221
  1. ;
  1. ;
  1. TRANS(ORIG,REF,PSOV) ; Extract Rx information for transmission to FI
  1. ; Input: ORIG -- Pointer to the rx in file #52
  1. ; REF -- Pointer to the refill in file #52.1
  1. ; (This is 0 if we are billing the original fill)
  1. ; PSOV -- Passed by reference. This array will be used
  1. ; to return the output (described below).
  1. ; Output: PSOE -- This is normally 1, or -1 if the NDC cannot
  1. ; be determined.
  1. ;
  1. ;
  1. ; Description of output variables to be passed to billing:
  1. ;
  1. ; PSOV("NDC") NDC # from the DRUG (#50) file
  1. ; PSOV("DIV") Pharmacy (in file #59) dispensing the rx
  1. ; PSOV("FDT") Rx Fill Date
  1. ; Last fill, field #101, or
  1. ; Dispensed, field #25
  1. ; PSOV("RX#") Prescription number, field #.01
  1. ; PSOV("QTY") Quantity, field #7
  1. ; PSOV("SUP") Days Supply, field #8
  1. ; PSOV("ISS") Issue Date, field #1
  1. ; PSOV("#REF") # Refills, field #9
  1. ; PSOV("COMP") 2 if manufactured in Pharmacy, else 1
  1. ; PSOV("DEA") DEA number from "PS" node in File 200
  1. ;
  1. N PSOE,PSORX S PSOE=1
  1. ;
  1. S PSORX(0)=$G(^PSRX(ORIG,0)),PSORX(2)=$G(^(2)),PSORX(3)=$G(^(3))
  1. S:$G(REF) PSORX("REF")=$G(^PSRX(ORIG,1,REF,0))
  1. I PSORX(0)="" S PSOE=-1 G TRANSQ
  1. ;
  1. S PSOV("RX#")=$P(PSORX(0),"^") ; prescription number
  1. ; - first check for a valid NDC #
  1. S PSOV("NDC")=$P($G(^PSDRUG(+$P(PSORX(0),"^",6),2)),"^",4)
  1. I +PSOV("NDC")=0 S PSOE=-1 G TRANSQ
  1. ;
  1. ; - extract everything else
  1. S PSOV("DIV")=$S($P($G(PSORX("REF")),"^",9):$P(PSORX("REF"),"^",9),1:$P(PSORX(2),"^",9)) ; pharmacy division
  1. S PSOV("FDT")=$S($G(REF):$E($P(PSORX("REF"),"^"),1,7),1:$E($P(PSORX(2),"^",2),1,7))
  1. I PSOV("FDT")="" S PSOV("FDT")=$S($P(PSORX(3),"^"):$P(PSORX(3),"^"),1:$P(PSORX(2),"^",5))
  1. ;
  1. S PSOV("QTY")=$S($P($G(PSORX("REF")),"^",4)'="":$P(PSORX("REF"),"^",4),1:$P(PSORX(0),"^",7)) ; quantity
  1. S PSOV("SUP")=$S($P($G(PSORX("REF")),"^",10)'="":$P(PSORX("REF"),"^",10),1:$P(PSORX(0),"^",8)) ; days supply
  1. S PSOV("ISS")=$P(PSORX(0),"^",13) ; date rx written
  1. S PSOV("#REF")=$P(PSORX(0),"^",9) ; # refills authorized
  1. ;
  1. 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
  1. ;
  1. ;*545 - get DEA#
  1. S PSOV("DEA")=$S($P(PSORX(0),"^",4):$$GDEA(+$P(PSORX(0),"^",4)),1:"")
  1. ;
  1. ;
  1. TRANSQ Q PSOE
  1. ;
  1. ;
  1. LABEL(RX,PSOLAP,PSOSITE,DUZ,PSOTRAMT) ; Print the label.
  1. ; Input: RX -- Pointer to the prescription in file #52
  1. ; PSOLAP -- Label printer
  1. ; PSOSITE -- Pointer to the Pharmacy in file #59
  1. ; DUZ -- Pointer to the use in file #200
  1. ; PSOTRAMT -- Amount to be paid
  1. ;
  1. ;
  1. Q:PSOLAP["LAT-TERM"
  1. Q:'$D(^PSRX(RX,0))
  1. Q:'$D(^PS(59,PSOSITE,0))
  1. N CT,II,III,NOW,RXFF,X,Y,PSOSYS,PSOPAR,PSOBARS,PDUZ,PSOBAR0,PSOBAR1,REPRINT,PSOCHAMP,PSHRX,DIQUIET
  1. S DIQUIET=1 D DT^DICRW
  1. I '$G(DT) S DT=$$DT^XLFDT
  1. S:$P($G(^PSRX(RX,"STA")),"^")'=3 REPRINT=""
  1. D:$P($G(^PSRX(RX,"STA")),"^")=3
  1. .S RXFF=0 F II=0:0 S II=$O(^PSRX(RX,1,II)) Q:'II S RXFF=II
  1. .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
  1. .S PSHRX=RX D EN^PSOHLSN1(RX,"OE","","Rx removed from CHAMPUS billing hold","A") S RX=PSHRX
  1. .K ^PSRX("AH",+$P($G(^PSRX(RX,"H")),"^"),RX) S ^PSRX(DA,"H")=""
  1. .D NOW^%DTC S NOW=%
  1. .S III=0 F CT=0:0 S CT=$O(^PSRX(RX,"A",CT)) Q:'CT S III=CT
  1. .S III=III+1,^PSRX(RX,"A",0)="^52.3DA^"_III_"^"_III
  1. .S ^PSRX(RX,"A",III,0)=NOW_"^"_"U"_"^"_+$G(DUZ)_"^"_$S(RXFF<6:RXFF,1:(RXFF+1))_"^"_"Rx removed from CHAMPUS billing hold"
  1. ;
  1. IO S %ZIS="",IOP=PSOLAP D ^%ZIS I POP H 5 G IO
  1. N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
  1. S PSOSYS=$G(^PS(59,PSOSITE,1))
  1. S PSOPAR=$G(^PS(59,PSOSITE,1)),PDUZ=DUZ
  1. S PPL=RX
  1. S PSOCHAMP=1
  1. S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&($P(PSOPAR,"^",19))
  1. D DQ^PSOLBL
  1. D ^%ZISC
  1. ;
  1. Q
  1. ;
  1. ;
  1. CHK(ORIG,REF) ; Should this rx be billed to the CHAMPUS Fiscal Intermediary?
  1. ; Input: ORIG -- Pointer to the rx in file #52
  1. ; REF -- Pointer to the refill in file #52.1, or
  1. ; 0 for the original fill
  1. ; Output: PSOB -- 0 => The rx should not be billed
  1. ; 1 => The rx may be billed.
  1. ;
  1. N PSOB
  1. ;
  1. ; - ignore CHAMPUS billing for certain RX Patient Statuses
  1. I $P($G(^PS(53,+$P($G(^PSRX(+$G(ORIG),0)),"^",3),0)),"^",8) G CHKQ
  1. ;
  1. S PSOB=1
  1. ;
  1. CHKQ Q +$G(PSOB)
  1. ;
  1. DEV ;Get devices
  1. N PSOTRION
  1. S PSOTRION=ION
  1. I $G(PSOLAP)]"",$G(PSOLAP)'=ION Q
  1. 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
  1. S PSOLAP=ION
  1. N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
  1. S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&($P($G(PSOPAR),"^",10))
  1. D ^%ZISC S ION=PSOTRION Q
  1. ;
  1. EXM ;Edit Champus Billing Exemption field
  1. I '$D(PSOPAR) D ^PSOLSET G EXM
  1. W ! K DIC S DIC="^PS(53,",DIC(0)="AEQMZ" D ^DIC K DIC I Y<0!($D(DTOUT))!($D(DUOUT)) G EXMQ
  1. W ! K DIE S DA=+Y,DIE="^PS(53,",DR=16 D ^DIE
  1. EXMQ K DIE,DIC,Y
  1. Q
  1. RESDIR ;Reset DIR just in case
  1. 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 "
  1. 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"
  1. S DIR("?",2)="Enter 'H' to hold label until Rx can be filled",DIR("?",3)="Enter 'P' for Rx profile"
  1. S:$P(PSOPAR,"^",26) DIR("?",5)="Enter 'L' to print labels without queuing"
  1. Q
  1. ;
  1. GDEA(IEN) ; Get DEA number
  1. N DEA
  1. S DEA=$$DEA^XUSER(0,IEN) ;DBIA2343
  1. Q DEA
  1. ;