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

IBECUS2.m

Go to the documentation of this file. 
  1. IBECUS2 ;DVAMC/RLM - TRICARE PHARMACY BILL TRANSACTION ;14-AUG-96
  1.  ;;2.0;INTEGRATED BILLING;**52,89,143,162,240,274,347**;21-MAR-94;Build 24
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1. EN ; Attempt to bill a prescription directly to the FI.
  1.  ;  Input:    IBKEY  --  1 ; 2, where
  1.  ;                         1 = Pointer to the prescription in file #52
  1.  ;                         2 = Pointer to the refill in file #52.1, or
  1.  ;                             0 for the original fill
  1.  ;           IBKEYD  --  1 ^ 2 ^ 3 ^ 4 ^ 5, where
  1.  ;                         1 = Rx label printing device
  1.  ;                         2 = Pointer to the Pharmacy in file #59
  1.  ;                         3 = Pointer to the Pharmacy user in file #200
  1.  ;                         4 = Pointer to the billing transaction
  1.  ;                             in file #351.5 (cancellations only)
  1.  ;                         5 = Product Selection Reason 
  1.  ;                                  (Resubmissions only)
  1.  ;          IBCHSET  --  Pointer to the Charge Set in file #363.1
  1.  ;         IBPRESCR  --  Facility Prescriber ID number
  1.  ;
  1.  ; - get rx data; make sure there is an NDC
  1.  K IBDRX,IBERR,IBAWPV,IBRESP
  1.  N DFN,IBRX,IBITEM,IBAWP
  1.  N DIQUIET S DIQUIET=1 D DT^DICRW
  1.  S IBRX=+IBKEY,IBREF=+$P(IBKEY,";",2)
  1.  I $$TRANS^PSOCPTRI(IBRX,IBREF,.IBDRX)<0 S IBERR=1 G ENQ
  1.  ;
  1.  ; - make sure the AWP is available
  1.  S IBDRX("NDC")=$$NDC(IBDRX("NDC"))
  1.  S IBITEM=+$$FNDBI^IBCRU2("NDC",IBDRX("NDC"))
  1.  I 'IBITEM S IBERR=9 G ENQ ;                     NDC is not in CM
  1.  D ITMCHG^IBCRCC(IBCHSET,IBITEM,DT,"",.IBAWPV)
  1.  I +IBAWPV'=1 S IBERR=10 G ENQ ;                  Not 1 rate for NDC
  1.  S IBAWP=$P(IBAWPV(+$O(IBAWPV(0))),"^",3)
  1.  I 'IBAWP S IBERR=11 G ENQ ;                     NDC has a zero charge
  1.  ;
  1.  ; - is patient data intact?
  1.  S DFN=+$$FILE^IBRXUTL(+IBRX,2)
  1.  S IBDPT(0)=$G(^DPT(DFN,0)),IBDPT(.11)=$G(^(.11)),IBDPT(.13)=$G(^(.13))
  1.  I IBDPT(0)="" S IBERR=4 G ENQ
  1.  ;
  1.  ; - is patient covered by TRICARE?
  1.  S IBCDFN=$$CUS^IBACUS(DFN,DT)
  1.  I 'IBCDFN S IBERR=2 G ENQ
  1.  ;
  1.  ; - get the BIN Number for the insurance company
  1.  S IBCDFND=$G(^DPT(DFN,.312,IBCDFN,0))
  1.  S IBBIN=$P($G(^DIC(36,+IBCDFND,3)),"^",3)
  1.  I $L(IBBIN)'=6 S IBERR=5 G ENQ
  1.  ;
  1.  ; - build line1:
  1.  ;      o pharmacy division
  1.  ;      o FI identifier (bin number)
  1.  ;      o commercial software package version (32)
  1.  ;      o billing transaction code  (01)
  1.  ;      o control #_pharmacy #_group (37 spaces)
  1.  ;      o insured person's ssn
  1.  ;      o person code (3 spaces)
  1.  ;
  1.  S IBFS=$C(28),IBGS=$C(29)
  1.  S IBLINE(1)=$$FILL(IBDRX("DIV"),2)_IBBIN_3201_$J("",37)
  1.  S IBLINE(1)=IBLINE(1)_$$LJUST($P(IBCDFND,"^",2),18)_$J("",3)
  1.  ;
  1.  ; - build line2:
  1.  ;      o patient dob
  1.  ;      o patient sex
  1.  ;      o patient rel. to insured
  1.  ;      o other coverage indicator (0)
  1.  ;      o rx fill date
  1.  ;
  1.  S IBLINE(2)=$$DATE($P(IBDPT(0),"^",3))_$P(IBDPT(0),"^",2)
  1.  S IBLINE(2)=IBLINE(2)_$S($P(IBCDFND,"^",16)>3:4,1:+$P(IBCDFND,"^",16))
  1.  S IBLINE(2)=IBLINE(2)_"0"_$$DATE(IBDRX("FDT"))
  1.  ;
  1.  ; - build line3:
  1.  ;      o patient first name
  1.  ;      o patient last name
  1.  ;      o insured's first name
  1.  ;      o insured's last name
  1.  ;      o address line 1, city, state, zip, phone
  1.  ;      
  1.  S IBLINE(3)=IBFS_"C700"_IBFS_"C90"
  1.  S IBLINE(3)=IBLINE(3)_IBFS_"CA"_$$LJUST($P($P(IBDPT(0),"^"),",",2),12)
  1.  S IBLINE(3)=IBLINE(3)_IBFS_"CB"_$$LJUST($P($P(IBDPT(0),"^"),","),15)
  1.  S IBLINE(3)=IBLINE(3)_IBFS_"CC"_$$LJUST($P($P(IBCDFND,"^",17),",",2),12)
  1.  S IBLINE(3)=IBLINE(3)_IBFS_"CD"_$$LJUST($P($P(IBCDFND,"^",17),","),15)
  1.  S IBLINE(3)=IBLINE(3)_IBFS_"CM"_$$LJUST($P(IBDPT(.11),"^"),30)
  1.  S IBLINE(3)=IBLINE(3)_IBFS_"CN"_$$LJUST($P(IBDPT(.11),"^",4),20)
  1.  S IBLINE(3)=IBLINE(3)_IBFS_"CO"_$$LJUST($P($G(^DIC(5,+$P(IBDPT(.11),"^",5),0)),"^",2),2)
  1.  S IBLINE(3)=IBLINE(3)_IBFS_"CP"_$$LJUST($P(IBDPT(.11),"^",6),9)
  1.  S IBLINE(3)=IBLINE(3)_IBFS_"CQ"_$$FILL($TR($P(IBDPT(.13),"^"),"-",""),10)
  1.  ;
  1.  ; - build line4:
  1.  ;      o prescription number
  1.  ;      o new/refill code
  1.  ;      o quantity
  1.  ;      o days supply
  1.  ;      o compound code (0) or if site param IBDRX("COMP")
  1.  ;      o drug NDC #
  1.  ;      o dispense as written? (0) or if resubmit look at IBKEYD
  1.  ;      o ingredient cost
  1.  ;      o Prescriber ID
  1.  ;      o date prescription written
  1.  ;      o # refills authorized
  1.  ;      o rx origin code (1)
  1.  ;      o rx denial clarification (00)
  1.  ;      o usual and customary charge (currently ingr cost * 5)
  1.  ;
  1.  ; - but first, strip trailing alpha characters from the rx number
  1.  S:$E(IBDRX("RX#"),$L(IBDRX("RX#")))]9 IBDRX("RX#")=$E(IBDRX("RX#"),1,$L(IBDRX("RX#"))-1)
  1.  S IBLINE(4)=IBGS_$$FILL(IBDRX("RX#"),7)
  1.  S IBLINE(4)=IBLINE(4)_$$FILL(IBREF,2)
  1.  S IBLINE(4)=IBLINE(4)_$$FILL($P(IBDRX("QTY"),"."),5)
  1.  S IBLINE(4)=IBLINE(4)_$$FILL(IBDRX("SUP"),3)
  1.  S IBLINE(4)=IBLINE(4)_$S(+$P($G(^IBE(350.9,1,9)),"^",15):IBDRX("COMP"),1:0)
  1.  S IBLINE(4)=IBLINE(4)_$$FILL($TR(IBDRX("NDC"),"-",""),11)
  1.  S IBLINE(4)=IBLINE(4)_$S($P($G(^IBA(351.53,+$P(IBKEYD,"^",5),0)),"^"):$P(^(0),"^"),1:0)
  1.  ;
  1.  S IBUAC=$$FILL(+($E($TR($J(IBAWP,0,2),".",""),1,5))*IBDRX("QTY"),6)
  1.  S IBLINE(4)=IBLINE(4)_IBUAC_$$LJUST($S(+$P($G(^IBE(350.9,1,9)),"^",14)&($L(IBDRX("DEA"))):IBDRX("DEA"),1:IBPRESCR),10)
  1.  S IBLINE(4)=IBLINE(4)_$$DATE(IBDRX("ISS"))
  1.  S IBLINE(4)=IBLINE(4)_$$FILL(IBDRX("#REF"),2)
  1.  S IBLINE(4)=IBLINE(4)_"100"_$$FILL(IBUAC*5,6)
  1.  ;
  1.  ; - build line5:  (not currently used, though must be submitted)
  1.  S IBLINE(5)=IBFS_"DA000000"_IBFS_"DC000200"_IBFS_"DG000000000000"_IBFS_"DI00"_IBFS_"DL"_$J("",10)
  1.  S IBLINE(5)=IBLINE(5)_IBFS_"DM00000"_IBFS_"DN01"_IBFS_"DO"_$J("",6)_IBFS_"DU000000"_IBFS_"DX000000"
  1.  S IBLINE(5)=IBLINE(5)_IBFS_"E4  "_IBFS_"E5  "_IBFS_"E6  "_IBFS_"E700000000"
  1.  ;
  1. OUT ; - send transaction to the commercial pos package
  1.  W $C(2)
  1.  F I=1:1:5 W IBLINE(I)
  1.  W $C(3)
  1.  W !
  1.  ;
  1.  ; - receive response
  1.  R IBRESP(1)#220:120 I '$T S IBERR=6 G ENQ
  1.  R IBRESP(2)#220:60,IBRESP(3):60 I '$L(IBRESP(3)) S IBERR=7 G ENQ
  1.  ;
  1.  S IBRESP(1)=$E(IBRESP(1),2,999)
  1.  ;
  1.  S XMCHAN=""
  1.  I $E(IBRESP(1),1,3)="   " D ERROR^IBECUS22 G ENQ
  1.  I $E(IBRESP(1),17)="D" D DUP^IBECUS22 G ENQ
  1.  ;
  1.  ; - file the billing transaction in file #351.51
  1.  D ^IBECUS21
  1.  ;
  1.  ; - quit if a reject
  1.  I $E(IBRESP(1),17)="R" G ENQ
  1.  ;
  1.  ; - if there was an error, file it and quit
  1.  I $E(IBRESP(1),1,3) D ERROR^IBECUS22 G ENQ
  1.  ;
  1.  ; - Queue tasks to print the label and create charges
  1.  F IBI="RXLAB;Rx Label print","RXBIL;Rx Billing" D TASK(IBI)
  1.  ;
  1.  ; - delete rx from billing queue
  1.  K ^IBA(351.5,"APOST",IBKEY)
  1.  ;
  1. ENQ I $G(IBERR) D ERROR^IBECUS22
  1.  Q
  1.  ;
  1.  ;
  1. TASK(IBDESC) ; Queue off label print, charge creation and cancellation jobs
  1.  ;  Input:  IBDESC  --  1 ; 2 , where
  1.  ;                        1 = routine label to execute
  1.  ;                        2 = task description
  1.  K ZTSAVE,ZTCPU,ZTSK
  1.  S ZTRTN=$P(IBDESC,";")_"^IBACUS",ZTDTH=$H,ZTIO=""
  1.  S ZTDESC="IB - "_$P(IBDESC,";",2)
  1.  F I="IBKEYD","IBCHTRN" S ZTSAVE(I)=""
  1.  D ^%ZTLOAD
  1.  Q
  1.  ;
  1.  ;
  1. DATE(X) ; Set date in the format yyyymmdd, or 8 spaces.
  1.  N Y
  1.  S Y=($E($G(X))+17)_$E($G(X),2,7)
  1.  Q $S($L(Y)=8:Y,1:$J("",8))
  1.  ;
  1. FILL(X,LEN) ; Zero-fill, right justified.
  1.  N Y
  1.  S:'$G(LEN) LEN=1
  1.  S Y=$E($G(X),1,LEN)
  1.  F  Q:$L(Y)>(LEN-1)  S Y="0"_Y
  1.  Q Y
  1.  ;
  1. LJUST(X,LEN) ; Space-fill, left justified.
  1.  N Y
  1.  S:'$G(LEN) LEN=1
  1.  S Y=$E($G(X),1,LEN)
  1.  F  Q:$L(Y)>(LEN-1)  S Y=Y_" "
  1.  Q Y
  1.  ;
  1. STRIPL(X) ; Strip leading spaces.
  1.  N Y S Y=$G(X)
  1.  F  Q:$E(Y)'=" "  S Y=$E(Y,2,999)
  1.  Q Y
  1.  ;
  1. NDC(X) ; Massage the NDC as it is stored in Pharmacy
  1.  ;  Input:  X  --  The NDC as it is stored in Pharmacy
  1.  ; Output:  X  --  The NDC in the format 5N 1"-" 4N 1"-" 2N
  1.  ;
  1.  I $G(X)="" S X="" G NDCQ
  1.  ;
  1.  N LEN,PCE,Y,Z
  1.  ;
  1.  S Z(1)=5,Z(2)=4,Z(3)=2
  1.  S PCE=0 F  S PCE=$O(Z(PCE)) Q:'PCE  S LEN=Z(PCE) D
  1.  .S Y=$P(X,"-",PCE)
  1.  .I $L(Y)>LEN S Y=$E(Y,2,LEN+1)
  1.  .I $L(+Y)<LEN S Y=$$FILL(Y,LEN)
  1.  .S $P(X,"-",PCE)=Y
  1.  ;
  1. NDCQ Q X