IBECUS2 ;DVAMC/RLM - TRICARE PHARMACY BILL TRANSACTION ;14-AUG-96
;;2.0;INTEGRATED BILLING;**52,89,143,162,240,274,347**;21-MAR-94;Build 24
;;Per VHA Directive 2004-038, this routine should not be modified.
;
EN ; Attempt to bill a prescription directly to the FI.
; Input: IBKEY -- 1 ; 2, where
; 1 = Pointer to the prescription in file #52
; 2 = Pointer to the refill in file #52.1, or
; 0 for the original fill
; IBKEYD -- 1 ^ 2 ^ 3 ^ 4 ^ 5, where
; 1 = Rx label printing device
; 2 = Pointer to the Pharmacy in file #59
; 3 = Pointer to the Pharmacy user in file #200
; 4 = Pointer to the billing transaction
; in file #351.5 (cancellations only)
; 5 = Product Selection Reason
; (Resubmissions only)
; IBCHSET -- Pointer to the Charge Set in file #363.1
; IBPRESCR -- Facility Prescriber ID number
;
; - get rx data; make sure there is an NDC
K IBDRX,IBERR,IBAWPV,IBRESP
N DFN,IBRX,IBITEM,IBAWP
N DIQUIET S DIQUIET=1 D DT^DICRW
S IBRX=+IBKEY,IBREF=+$P(IBKEY,";",2)
I $$TRANS^PSOCPTRI(IBRX,IBREF,.IBDRX)<0 S IBERR=1 G ENQ
;
; - make sure the AWP is available
S IBDRX("NDC")=$$NDC(IBDRX("NDC"))
S IBITEM=+$$FNDBI^IBCRU2("NDC",IBDRX("NDC"))
I 'IBITEM S IBERR=9 G ENQ ; NDC is not in CM
D ITMCHG^IBCRCC(IBCHSET,IBITEM,DT,"",.IBAWPV)
I +IBAWPV'=1 S IBERR=10 G ENQ ; Not 1 rate for NDC
S IBAWP=$P(IBAWPV(+$O(IBAWPV(0))),"^",3)
I 'IBAWP S IBERR=11 G ENQ ; NDC has a zero charge
;
; - is patient data intact?
S DFN=+$$FILE^IBRXUTL(+IBRX,2)
S IBDPT(0)=$G(^DPT(DFN,0)),IBDPT(.11)=$G(^(.11)),IBDPT(.13)=$G(^(.13))
I IBDPT(0)="" S IBERR=4 G ENQ
;
; - is patient covered by TRICARE?
S IBCDFN=$$CUS^IBACUS(DFN,DT)
I 'IBCDFN S IBERR=2 G ENQ
;
; - get the BIN Number for the insurance company
S IBCDFND=$G(^DPT(DFN,.312,IBCDFN,0))
S IBBIN=$P($G(^DIC(36,+IBCDFND,3)),"^",3)
I $L(IBBIN)'=6 S IBERR=5 G ENQ
;
; - build line1:
; o pharmacy division
; o FI identifier (bin number)
; o commercial software package version (32)
; o billing transaction code (01)
; o control #_pharmacy #_group (37 spaces)
; o insured person's ssn
; o person code (3 spaces)
;
S IBFS=$C(28),IBGS=$C(29)
S IBLINE(1)=$$FILL(IBDRX("DIV"),2)_IBBIN_3201_$J("",37)
S IBLINE(1)=IBLINE(1)_$$LJUST($P(IBCDFND,"^",2),18)_$J("",3)
;
; - build line2:
; o patient dob
; o patient sex
; o patient rel. to insured
; o other coverage indicator (0)
; o rx fill date
;
S IBLINE(2)=$$DATE($P(IBDPT(0),"^",3))_$P(IBDPT(0),"^",2)
S IBLINE(2)=IBLINE(2)_$S($P(IBCDFND,"^",16)>3:4,1:+$P(IBCDFND,"^",16))
S IBLINE(2)=IBLINE(2)_"0"_$$DATE(IBDRX("FDT"))
;
; - build line3:
; o patient first name
; o patient last name
; o insured's first name
; o insured's last name
; o address line 1, city, state, zip, phone
;
S IBLINE(3)=IBFS_"C700"_IBFS_"C90"
S IBLINE(3)=IBLINE(3)_IBFS_"CA"_$$LJUST($P($P(IBDPT(0),"^"),",",2),12)
S IBLINE(3)=IBLINE(3)_IBFS_"CB"_$$LJUST($P($P(IBDPT(0),"^"),","),15)
S IBLINE(3)=IBLINE(3)_IBFS_"CC"_$$LJUST($P($P(IBCDFND,"^",17),",",2),12)
S IBLINE(3)=IBLINE(3)_IBFS_"CD"_$$LJUST($P($P(IBCDFND,"^",17),","),15)
S IBLINE(3)=IBLINE(3)_IBFS_"CM"_$$LJUST($P(IBDPT(.11),"^"),30)
S IBLINE(3)=IBLINE(3)_IBFS_"CN"_$$LJUST($P(IBDPT(.11),"^",4),20)
S IBLINE(3)=IBLINE(3)_IBFS_"CO"_$$LJUST($P($G(^DIC(5,+$P(IBDPT(.11),"^",5),0)),"^",2),2)
S IBLINE(3)=IBLINE(3)_IBFS_"CP"_$$LJUST($P(IBDPT(.11),"^",6),9)
S IBLINE(3)=IBLINE(3)_IBFS_"CQ"_$$FILL($TR($P(IBDPT(.13),"^"),"-",""),10)
;
; - build line4:
; o prescription number
; o new/refill code
; o quantity
; o days supply
; o compound code (0) or if site param IBDRX("COMP")
; o drug NDC #
; o dispense as written? (0) or if resubmit look at IBKEYD
; o ingredient cost
; o Prescriber ID
; o date prescription written
; o # refills authorized
; o rx origin code (1)
; o rx denial clarification (00)
; o usual and customary charge (currently ingr cost * 5)
;
; - but first, strip trailing alpha characters from the rx number
S:$E(IBDRX("RX#"),$L(IBDRX("RX#")))]9 IBDRX("RX#")=$E(IBDRX("RX#"),1,$L(IBDRX("RX#"))-1)
S IBLINE(4)=IBGS_$$FILL(IBDRX("RX#"),7)
S IBLINE(4)=IBLINE(4)_$$FILL(IBREF,2)
S IBLINE(4)=IBLINE(4)_$$FILL($P(IBDRX("QTY"),"."),5)
S IBLINE(4)=IBLINE(4)_$$FILL(IBDRX("SUP"),3)
S IBLINE(4)=IBLINE(4)_$S(+$P($G(^IBE(350.9,1,9)),"^",15):IBDRX("COMP"),1:0)
S IBLINE(4)=IBLINE(4)_$$FILL($TR(IBDRX("NDC"),"-",""),11)
S IBLINE(4)=IBLINE(4)_$S($P($G(^IBA(351.53,+$P(IBKEYD,"^",5),0)),"^"):$P(^(0),"^"),1:0)
;
S IBUAC=$$FILL(+($E($TR($J(IBAWP,0,2),".",""),1,5))*IBDRX("QTY"),6)
S IBLINE(4)=IBLINE(4)_IBUAC_$$LJUST($S(+$P($G(^IBE(350.9,1,9)),"^",14)&($L(IBDRX("DEA"))):IBDRX("DEA"),1:IBPRESCR),10)
S IBLINE(4)=IBLINE(4)_$$DATE(IBDRX("ISS"))
S IBLINE(4)=IBLINE(4)_$$FILL(IBDRX("#REF"),2)
S IBLINE(4)=IBLINE(4)_"100"_$$FILL(IBUAC*5,6)
;
; - build line5: (not currently used, though must be submitted)
S IBLINE(5)=IBFS_"DA000000"_IBFS_"DC000200"_IBFS_"DG000000000000"_IBFS_"DI00"_IBFS_"DL"_$J("",10)
S IBLINE(5)=IBLINE(5)_IBFS_"DM00000"_IBFS_"DN01"_IBFS_"DO"_$J("",6)_IBFS_"DU000000"_IBFS_"DX000000"
S IBLINE(5)=IBLINE(5)_IBFS_"E4 "_IBFS_"E5 "_IBFS_"E6 "_IBFS_"E700000000"
;
OUT ; - send transaction to the commercial pos package
W $C(2)
F I=1:1:5 W IBLINE(I)
W $C(3)
W !
;
; - receive response
R IBRESP(1)#220:120 I '$T S IBERR=6 G ENQ
R IBRESP(2)#220:60,IBRESP(3):60 I '$L(IBRESP(3)) S IBERR=7 G ENQ
;
S IBRESP(1)=$E(IBRESP(1),2,999)
;
S XMCHAN=""
I $E(IBRESP(1),1,3)=" " D ERROR^IBECUS22 G ENQ
I $E(IBRESP(1),17)="D" D DUP^IBECUS22 G ENQ
;
; - file the billing transaction in file #351.51
D ^IBECUS21
;
; - quit if a reject
I $E(IBRESP(1),17)="R" G ENQ
;
; - if there was an error, file it and quit
I $E(IBRESP(1),1,3) D ERROR^IBECUS22 G ENQ
;
; - Queue tasks to print the label and create charges
F IBI="RXLAB;Rx Label print","RXBIL;Rx Billing" D TASK(IBI)
;
; - delete rx from billing queue
K ^IBA(351.5,"APOST",IBKEY)
;
ENQ I $G(IBERR) D ERROR^IBECUS22
Q
;
;
TASK(IBDESC) ; Queue off label print, charge creation and cancellation jobs
; Input: IBDESC -- 1 ; 2 , where
; 1 = routine label to execute
; 2 = task description
K ZTSAVE,ZTCPU,ZTSK
S ZTRTN=$P(IBDESC,";")_"^IBACUS",ZTDTH=$H,ZTIO=""
S ZTDESC="IB - "_$P(IBDESC,";",2)
F I="IBKEYD","IBCHTRN" S ZTSAVE(I)=""
D ^%ZTLOAD
Q
;
;
DATE(X) ; Set date in the format yyyymmdd, or 8 spaces.
N Y
S Y=($E($G(X))+17)_$E($G(X),2,7)
Q $S($L(Y)=8:Y,1:$J("",8))
;
FILL(X,LEN) ; Zero-fill, right justified.
N Y
S:'$G(LEN) LEN=1
S Y=$E($G(X),1,LEN)
F Q:$L(Y)>(LEN-1) S Y="0"_Y
Q Y
;
LJUST(X,LEN) ; Space-fill, left justified.
N Y
S:'$G(LEN) LEN=1
S Y=$E($G(X),1,LEN)
F Q:$L(Y)>(LEN-1) S Y=Y_" "
Q Y
;
STRIPL(X) ; Strip leading spaces.
N Y S Y=$G(X)
F Q:$E(Y)'=" " S Y=$E(Y,2,999)
Q Y
;
NDC(X) ; Massage the NDC as it is stored in Pharmacy
; Input: X -- The NDC as it is stored in Pharmacy
; Output: X -- The NDC in the format 5N 1"-" 4N 1"-" 2N
;
I $G(X)="" S X="" G NDCQ
;
N LEN,PCE,Y,Z
;
S Z(1)=5,Z(2)=4,Z(3)=2
S PCE=0 F S PCE=$O(Z(PCE)) Q:'PCE S LEN=Z(PCE) D
.S Y=$P(X,"-",PCE)
.I $L(Y)>LEN S Y=$E(Y,2,LEN+1)
.I $L(+Y)<LEN S Y=$$FILL(Y,LEN)
.S $P(X,"-",PCE)=Y
;
NDCQ Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECUS2 7917 printed Apr 09, 2024@21:28:54 Page 2
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
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN ; Attempt to bill a prescription directly to the FI.
+1 ; Input: IBKEY -- 1 ; 2, where
+2 ; 1 = Pointer to the prescription in file #52
+3 ; 2 = Pointer to the refill in file #52.1, or
+4 ; 0 for the original fill
+5 ; IBKEYD -- 1 ^ 2 ^ 3 ^ 4 ^ 5, where
+6 ; 1 = Rx label printing device
+7 ; 2 = Pointer to the Pharmacy in file #59
+8 ; 3 = Pointer to the Pharmacy user in file #200
+9 ; 4 = Pointer to the billing transaction
+10 ; in file #351.5 (cancellations only)
+11 ; 5 = Product Selection Reason
+12 ; (Resubmissions only)
+13 ; IBCHSET -- Pointer to the Charge Set in file #363.1
+14 ; IBPRESCR -- Facility Prescriber ID number
+15 ;
+16 ; - get rx data; make sure there is an NDC
+17 KILL IBDRX,IBERR,IBAWPV,IBRESP
+18 NEW DFN,IBRX,IBITEM,IBAWP
+19 NEW DIQUIET
SET DIQUIET=1
DO DT^DICRW
+20 SET IBRX=+IBKEY
SET IBREF=+$PIECE(IBKEY,";",2)
+21 IF $$TRANS^PSOCPTRI(IBRX,IBREF,.IBDRX)<0
SET IBERR=1
GOTO ENQ
+22 ;
+23 ; - make sure the AWP is available
+24 SET IBDRX("NDC")=$$NDC(IBDRX("NDC"))
+25 SET IBITEM=+$$FNDBI^IBCRU2("NDC",IBDRX("NDC"))
+26 ; NDC is not in CM
IF 'IBITEM
SET IBERR=9
GOTO ENQ
+27 DO ITMCHG^IBCRCC(IBCHSET,IBITEM,DT,"",.IBAWPV)
+28 ; Not 1 rate for NDC
IF +IBAWPV'=1
SET IBERR=10
GOTO ENQ
+29 SET IBAWP=$PIECE(IBAWPV(+$ORDER(IBAWPV(0))),"^",3)
+30 ; NDC has a zero charge
IF 'IBAWP
SET IBERR=11
GOTO ENQ
+31 ;
+32 ; - is patient data intact?
+33 SET DFN=+$$FILE^IBRXUTL(+IBRX,2)
+34 SET IBDPT(0)=$GET(^DPT(DFN,0))
SET IBDPT(.11)=$GET(^(.11))
SET IBDPT(.13)=$GET(^(.13))
+35 IF IBDPT(0)=""
SET IBERR=4
GOTO ENQ
+36 ;
+37 ; - is patient covered by TRICARE?
+38 SET IBCDFN=$$CUS^IBACUS(DFN,DT)
+39 IF 'IBCDFN
SET IBERR=2
GOTO ENQ
+40 ;
+41 ; - get the BIN Number for the insurance company
+42 SET IBCDFND=$GET(^DPT(DFN,.312,IBCDFN,0))
+43 SET IBBIN=$PIECE($GET(^DIC(36,+IBCDFND,3)),"^",3)
+44 IF $LENGTH(IBBIN)'=6
SET IBERR=5
GOTO ENQ
+45 ;
+46 ; - build line1:
+47 ; o pharmacy division
+48 ; o FI identifier (bin number)
+49 ; o commercial software package version (32)
+50 ; o billing transaction code (01)
+51 ; o control #_pharmacy #_group (37 spaces)
+52 ; o insured person's ssn
+53 ; o person code (3 spaces)
+54 ;
+55 SET IBFS=$CHAR(28)
SET IBGS=$CHAR(29)
+56 SET IBLINE(1)=$$FILL(IBDRX("DIV"),2)_IBBIN_3201_$JUSTIFY("",37)
+57 SET IBLINE(1)=IBLINE(1)_$$LJUST($PIECE(IBCDFND,"^",2),18)_$JUSTIFY("",3)
+58 ;
+59 ; - build line2:
+60 ; o patient dob
+61 ; o patient sex
+62 ; o patient rel. to insured
+63 ; o other coverage indicator (0)
+64 ; o rx fill date
+65 ;
+66 SET IBLINE(2)=$$DATE($PIECE(IBDPT(0),"^",3))_$PIECE(IBDPT(0),"^",2)
+67 SET IBLINE(2)=IBLINE(2)_$SELECT($PIECE(IBCDFND,"^",16)>3:4,1:+$PIECE(IBCDFND,"^",16))
+68 SET IBLINE(2)=IBLINE(2)_"0"_$$DATE(IBDRX("FDT"))
+69 ;
+70 ; - build line3:
+71 ; o patient first name
+72 ; o patient last name
+73 ; o insured's first name
+74 ; o insured's last name
+75 ; o address line 1, city, state, zip, phone
+76 ;
+77 SET IBLINE(3)=IBFS_"C700"_IBFS_"C90"
+78 SET IBLINE(3)=IBLINE(3)_IBFS_"CA"_$$LJUST($PIECE($PIECE(IBDPT(0),"^"),",",2),12)
+79 SET IBLINE(3)=IBLINE(3)_IBFS_"CB"_$$LJUST($PIECE($PIECE(IBDPT(0),"^"),","),15)
+80 SET IBLINE(3)=IBLINE(3)_IBFS_"CC"_$$LJUST($PIECE($PIECE(IBCDFND,"^",17),",",2),12)
+81 SET IBLINE(3)=IBLINE(3)_IBFS_"CD"_$$LJUST($PIECE($PIECE(IBCDFND,"^",17),","),15)
+82 SET IBLINE(3)=IBLINE(3)_IBFS_"CM"_$$LJUST($PIECE(IBDPT(.11),"^"),30)
+83 SET IBLINE(3)=IBLINE(3)_IBFS_"CN"_$$LJUST($PIECE(IBDPT(.11),"^",4),20)
+84 SET IBLINE(3)=IBLINE(3)_IBFS_"CO"_$$LJUST($PIECE($GET(^DIC(5,+$PIECE(IBDPT(.11),"^",5),0)),"^",2),2)
+85 SET IBLINE(3)=IBLINE(3)_IBFS_"CP"_$$LJUST($PIECE(IBDPT(.11),"^",6),9)
+86 SET IBLINE(3)=IBLINE(3)_IBFS_"CQ"_$$FILL($TRANSLATE($PIECE(IBDPT(.13),"^"),"-",""),10)
+87 ;
+88 ; - build line4:
+89 ; o prescription number
+90 ; o new/refill code
+91 ; o quantity
+92 ; o days supply
+93 ; o compound code (0) or if site param IBDRX("COMP")
+94 ; o drug NDC #
+95 ; o dispense as written? (0) or if resubmit look at IBKEYD
+96 ; o ingredient cost
+97 ; o Prescriber ID
+98 ; o date prescription written
+99 ; o # refills authorized
+100 ; o rx origin code (1)
+101 ; o rx denial clarification (00)
+102 ; o usual and customary charge (currently ingr cost * 5)
+103 ;
+104 ; - but first, strip trailing alpha characters from the rx number
+105 if $EXTRACT(IBDRX("RX#"),$LENGTH(IBDRX("RX#")))]9
SET IBDRX("RX#")=$EXTRACT(IBDRX("RX#"),1,$LENGTH(IBDRX("RX#"))-1)
+106 SET IBLINE(4)=IBGS_$$FILL(IBDRX("RX#"),7)
+107 SET IBLINE(4)=IBLINE(4)_$$FILL(IBREF,2)
+108 SET IBLINE(4)=IBLINE(4)_$$FILL($PIECE(IBDRX("QTY"),"."),5)
+109 SET IBLINE(4)=IBLINE(4)_$$FILL(IBDRX("SUP"),3)
+110 SET IBLINE(4)=IBLINE(4)_$SELECT(+$PIECE($GET(^IBE(350.9,1,9)),"^",15):IBDRX("COMP"),1:0)
+111 SET IBLINE(4)=IBLINE(4)_$$FILL($TRANSLATE(IBDRX("NDC"),"-",""),11)
+112 SET IBLINE(4)=IBLINE(4)_$SELECT($PIECE($GET(^IBA(351.53,+$PIECE(IBKEYD,"^",5),0)),"^"):$PIECE(^(0),"^"),1:0)
+113 ;
+114 SET IBUAC=$$FILL(+($EXTRACT($TRANSLATE($JUSTIFY(IBAWP,0,2),".",""),1,5))*IBDRX("QTY"),6)
+115 SET IBLINE(4)=IBLINE(4)_IBUAC_$$LJUST($SELECT(+$PIECE($GET(^IBE(350.9,1,9)),"^",14)&($LENGTH(IBDRX("DEA"))):IBDRX("DEA"),1:IBPRESCR),10)
+116 SET IBLINE(4)=IBLINE(4)_$$DATE(IBDRX("ISS"))
+117 SET IBLINE(4)=IBLINE(4)_$$FILL(IBDRX("#REF"),2)
+118 SET IBLINE(4)=IBLINE(4)_"100"_$$FILL(IBUAC*5,6)
+119 ;
+120 ; - build line5: (not currently used, though must be submitted)
+121 SET IBLINE(5)=IBFS_"DA000000"_IBFS_"DC000200"_IBFS_"DG000000000000"_IBFS_"DI00"_IBFS_"DL"_$JUSTIFY("",10)
+122 SET IBLINE(5)=IBLINE(5)_IBFS_"DM00000"_IBFS_"DN01"_IBFS_"DO"_$JUSTIFY("",6)_IBFS_"DU000000"_IBFS_"DX000000"
+123 SET IBLINE(5)=IBLINE(5)_IBFS_"E4 "_IBFS_"E5 "_IBFS_"E6 "_IBFS_"E700000000"
+124 ;
OUT ; - send transaction to the commercial pos package
+1 WRITE $CHAR(2)
+2 FOR I=1:1:5
WRITE IBLINE(I)
+3 WRITE $CHAR(3)
+4 WRITE !
+5 ;
+6 ; - receive response
+7 READ IBRESP(1)#220:120
IF '$TEST
SET IBERR=6
GOTO ENQ
+8 READ IBRESP(2)#220:60,IBRESP(3):60
IF '$LENGTH(IBRESP(3))
SET IBERR=7
GOTO ENQ
+9 ;
+10 SET IBRESP(1)=$EXTRACT(IBRESP(1),2,999)
+11 ;
+12 SET XMCHAN=""
+13 IF $EXTRACT(IBRESP(1),1,3)=" "
DO ERROR^IBECUS22
GOTO ENQ
+14 IF $EXTRACT(IBRESP(1),17)="D"
DO DUP^IBECUS22
GOTO ENQ
+15 ;
+16 ; - file the billing transaction in file #351.51
+17 DO ^IBECUS21
+18 ;
+19 ; - quit if a reject
+20 IF $EXTRACT(IBRESP(1),17)="R"
GOTO ENQ
+21 ;
+22 ; - if there was an error, file it and quit
+23 IF $EXTRACT(IBRESP(1),1,3)
DO ERROR^IBECUS22
GOTO ENQ
+24 ;
+25 ; - Queue tasks to print the label and create charges
+26 FOR IBI="RXLAB;Rx Label print","RXBIL;Rx Billing"
DO TASK(IBI)
+27 ;
+28 ; - delete rx from billing queue
+29 KILL ^IBA(351.5,"APOST",IBKEY)
+30 ;
ENQ IF $GET(IBERR)
DO ERROR^IBECUS22
+1 QUIT
+2 ;
+3 ;
TASK(IBDESC) ; Queue off label print, charge creation and cancellation jobs
+1 ; Input: IBDESC -- 1 ; 2 , where
+2 ; 1 = routine label to execute
+3 ; 2 = task description
+4 KILL ZTSAVE,ZTCPU,ZTSK
+5 SET ZTRTN=$PIECE(IBDESC,";")_"^IBACUS"
SET ZTDTH=$HOROLOG
SET ZTIO=""
+6 SET ZTDESC="IB - "_$PIECE(IBDESC,";",2)
+7 FOR I="IBKEYD","IBCHTRN"
SET ZTSAVE(I)=""
+8 DO ^%ZTLOAD
+9 QUIT
+10 ;
+11 ;
DATE(X) ; Set date in the format yyyymmdd, or 8 spaces.
+1 NEW Y
+2 SET Y=($EXTRACT($GET(X))+17)_$EXTRACT($GET(X),2,7)
+3 QUIT $SELECT($LENGTH(Y)=8:Y,1:$JUSTIFY("",8))
+4 ;
FILL(X,LEN) ; Zero-fill, right justified.
+1 NEW Y
+2 if '$GET(LEN)
SET LEN=1
+3 SET Y=$EXTRACT($GET(X),1,LEN)
+4 FOR
if $LENGTH(Y)>(LEN-1)
QUIT
SET Y="0"_Y
+5 QUIT Y
+6 ;
LJUST(X,LEN) ; Space-fill, left justified.
+1 NEW Y
+2 if '$GET(LEN)
SET LEN=1
+3 SET Y=$EXTRACT($GET(X),1,LEN)
+4 FOR
if $LENGTH(Y)>(LEN-1)
QUIT
SET Y=Y_" "
+5 QUIT Y
+6 ;
STRIPL(X) ; Strip leading spaces.
+1 NEW Y
SET Y=$GET(X)
+2 FOR
if $EXTRACT(Y)'=" "
QUIT
SET Y=$EXTRACT(Y,2,999)
+3 QUIT Y
+4 ;
NDC(X) ; Massage the NDC as it is stored in Pharmacy
+1 ; Input: X -- The NDC as it is stored in Pharmacy
+2 ; Output: X -- The NDC in the format 5N 1"-" 4N 1"-" 2N
+3 ;
+4 IF $GET(X)=""
SET X=""
GOTO NDCQ
+5 ;
+6 NEW LEN,PCE,Y,Z
+7 ;
+8 SET Z(1)=5
SET Z(2)=4
SET Z(3)=2
+9 SET PCE=0
FOR
SET PCE=$ORDER(Z(PCE))
if 'PCE
QUIT
SET LEN=Z(PCE)
Begin DoDot:1
+10 SET Y=$PIECE(X,"-",PCE)
+11 IF $LENGTH(Y)>LEN
SET Y=$EXTRACT(Y,2,LEN+1)
+12 IF $LENGTH(+Y)<LEN
SET Y=$$FILL(Y,LEN)
+13 SET $PIECE(X,"-",PCE)=Y
End DoDot:1
+14 ;
NDCQ QUIT X
