IBCSC5A ;ALB/ARH - ADD/ENTER PRESCRIPTION FILLS ;12/27/93
;;2.0;INTEGRATED BILLING;**27,52,106,51,160,137,245,309,347,405,432**;21-MAR-94;Build 192
;;Per VHA Directive 2004-038, this routine should not be modified.
;
EN ;add/edit prescription fills for a bill, IBIFN required
S IBX=$$BILL(IBIFN) Q:'IBIFN S DFN=+IBX,IBDT1=$P(IBX,U,2),IBDT2=$P(IBX,U,3),IBRXALL=$P(IBX,U,4)
D SET(IBIFN,.IBRXA,"")
D RXDISP^IBCSC5C(DFN,IBDT1,IBDT2,.IBPR,.IBPRO,.IBRXA,IBRXALL) I +$P($G(IBPRO),U,2) D NEWRX^IBCSC5C(+IBPRO) I +$G(IBLIST) D ADDNEW^IBCSC5C(IBIFN,IBLIST,.IBPR,.IBPRO) S DGRVRCAL=1
S IBRXAP=+$G(IBPRO) D SET(IBIFN,.IBRXA,.IBRXAP),DISP(.IBRXA,.IBRXAP)
E1 S IBPIFN=0,IBRX=$$ASKRX(.IBRXAP,.IBPRO) G:IBRX="" EXIT S IBDT=$P(IBRX,U,2),IBRX=$P(IBRX,U,1),DGRVRCAL=1
I 'IBDT S IBDT=$O(IBRXA(IBRX,0)) S:'IBDT IBDT=$O(IBPR(IBRX,0)) S IBDT=$$ASKDT(IBDT1,IBDT2,IBDT) G:'IBDT E1
I +$$RXDUP^IBCU3(IBRX,IBDT,IBIFN,1),'$D(IBRXA(IBRX,IBDT)) G E1
I '$D(IBPR(IBRX,IBDT)) W !,"This rx fill does not exist in Pharmacy for this patient!",!
S IBPIFN=$G(IBRXA(IBRX,IBDT)),IBDRG=$P(IBPIFN,U,2)
I 'IBPIFN S IBX=$G(IBPR(IBRX,IBDT)),IBPIFN=$$ADD(IBRX,IBIFN,IBDT,$P(IBX,U,3),$P(IBX,U,1),$P(IBX,U,4,6),$P(IBX,U,2)) D G:'IBPIFN E1
. I 'IBPIFN W " ??" Q
. W " ... ADDED"
D EDIT(+IBPIFN,$P(IBPIFN,U,7)) S IBRXAP=+$G(IBPRO) D SET(IBIFN,.IBRXA,.IBRXAP) G E1
;
EXIT ;
K IBPIFN,IBRX,IBDRG,IBX,IBDT1,IBDT2,IBRXA,IBPR,IBDT,IBLIST,IBPRO,IBRXAP,IBRXALL
Q
;
ASKRX(IBRXAP,IBPRO) ;
N X,Y,IBY,IBX W ! S IBX=""
I +$G(IBIFN) S DIR("?")="The prescription number for the fill. "_$$HTEXT^IBCSC5C,DIR("??")="^D HELP^IBCSC5A("_IBIFN_")"
S DIR("A")="Select RX FILL",DIR(0)="FO^1:11^K:X'?.UN X" D ^DIR I $D(DIRUT)!(Y'?.AN) S Y="" K DIR,DIRUT G ARX1E
S IBX=Y I $D(IBRXAP)<10,$D(IBPRO)<10 G ARX1E
;
S IBY=$G(IBRXAP(IBX)) S:IBY="" IBY=$G(IBPRO(IBX)) I IBY="" G ARX1E
W ! S DIR(0)="YO",DIR("A")="ADD/EDIT RX FILL "_$P(IBY,U,1)_" FOR "_$$FMTE^XLFDT($P(IBY,U,2))_" CORRECT",DIR("B")="YES"
D ^DIR K DIR I Y=1,'$D(DIRUT) S IBX=IBY
ARX1E Q IBX
;
ASKDT(IBDT1,IBDT2,IBDT) ;
S DIR("A")="Select RX FILL DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX",DIR("B")=$$FMTE^XLFDT(IBDT) D ^DIR K DIR,DTOUT,DIRUT
Q $S(Y?7N:Y,1:0)
;
ADD(RX,IFN,IBDT,DRUG,PIFN,OTHER,IBRF) ;
N IBX,X,Y,DD,DO,DA,DIC,DLAYGO
S IBX=0 S DRUG=$$DRUG($G(DRUG)) G:'DRUG ADDE
S DIC="^IBA(362.4,",DIC(0)="AQL",X=RX,DLAYGO=362.4 D FILE^DICN
I Y>0 D
. ; IB *2.0*432 Stuff ISSUE DATE from file 52 when adding new RX to 362.4
. D ORDT($P(OTHER,U,4),+Y)
. S DIE=DIC,(IBX,DA)=+Y,DR=".02////"_IFN_";.03////"_IBDT_";.04////"_DRUG_";.05////"_+PIFN_";.06////"_$P(OTHER,U,1)_";.07////"_$P(OTHER,U,2)_";.08////"_$P(OTHER,U,3) S:$L($G(IBRF)) DR=DR_";.1////"_IBRF D ^DIE K DIE,DIC,DA,DR
. S DGRVRCAL=1
ADDE Q IBX
;
EDIT(PIFN,REVIEN) ;
N IBCHG,DIE,DR,DA,DIC,DIDEL,IBORDT
; IB*2.0*432 - display RX Order date to user, if available
S IBORDT=$P($G(^IBA(362.4,PIFN,0)),U,11)
W:IBORDT'="" !,"Date RX Ordered: ",$$FMTE^XLFDT(IBORDT)
S DIDEL=362.4,DIE="^IBA(362.4,"
S DR=".01;.03;.04;.06;.07;.08;.09;.1"
S DA=PIFN D ^DIE
I '$D(^IBA(362.4,PIFN,0)),$G(REVIEN) D ; Deleted RX - delete related rev code/CPT code
. I $P($G(^DGCR(399,IBIFN,"RC",REVIEN,0)),U,15) S DA(1)=IBIFN,DA=$P(^(0),U,15),DIK="^DGCR(399,"_DA(1)_",""CP""," D ^DIK
. S DA=REVIEN,DA(1)=IBIFN,DIK="^DGCR(399,"_DA(1)_",""RC""," D ^DIK
. S DGRVRCAL=1
Q
;
SET(IFN,RXARR,RXARRP) ;setup array of all rx fills for bill, array name should be passed by reference
;returns: RXARR(RX #, FILL DT)=RX IFN (362.4) ^ DRUG ^ DAYS SUPPLY ^ QTY ^ NDC # ^ Charge if known ^ ien of associated rev code multiple, if known ^ NDC FORMAT INDICATOR (1-4)^ORDER DATE
; RXARR=BILL IFN ^ RX count
N CNT,IBX,IBY,IBZ,PIFN,IBC,IBCNT,IBRC S IBCNT=+$G(RXARRP),IBC="AIFN"_$G(IFN) K RXARR,RXARRP
;
D RCITEM(IFN,"IBRC",3)
S (CNT,IBX)=0 F S IBX=$O(^IBA(362.4,IBC,IBX)) Q:IBX="" S PIFN=0 F S PIFN=$O(^IBA(362.4,IBC,IBX,PIFN)) Q:'PIFN D
.S IBY=$G(^IBA(362.4,PIFN,0)) Q:IBY="" S CNT=CNT+1,RXARR($P(IBY,U,1),+$P(IBY,U,3))=PIFN_U_$P(IBY,U,4)_U_$P(IBY,U,6,8),$P(RXARR($P(IBY,U),+$P(IBY,U,3)),U,6)=$$CHG^IBCF4(PIFN,3,.IBRC)
. I $G(IFN) S $P(RXARR($P(IBY,U),+$P(IBY,U,3)),U,7)=$$FINDREV(IFN,3,PIFN)
. S $P(RXARR($P(IBY,U),+$P(IBY,U,3)),U,8)=$P(IBY,U,9)
. ; IB *2.0*432 include ORDER DATE from file 362.4 in output formatter
. S $P(RXARR($P(IBY,U),+$P(IBY,U,3)),U,9)=$P(IBY,U,11)
;
S RXARR=$G(IFN)_"^"_CNT
S IBX=0 F S IBX=$O(RXARR(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(RXARR(IBX,IBY)) Q:'IBY S IBCNT=IBCNT+1,RXARRP(IBCNT)=IBX_"^"_IBY_"^"_$P(RXARR(IBX,IBY),U,7)
Q
;
DISP(RXARR,RXARRP) ;screen display of existing fills for a bill: input should be print order array returned by SET^IBCSC5A: RXARR(RX,DT)=RX IFN (362.4) ^ DRUG, passed by reference
N IBX,IBY,IBZ,IBS,IBP,IBIFN
W !!,?5,"----------------- Existing Prescriptions on Bill -----------------",!
S IBIFN=+$G(RXARR)
S IBI=0 F S IBI=$O(RXARRP(IBI)) Q:IBI="" S IBX=$P(RXARRP(IBI),U,1),IBY=$P(RXARRP(IBI),U,2) I $D(RXARR(IBX,IBY)) D
. S IBS=$$RXSTAT^IBCU1(+$P(RXARR(IBX,IBY),U,2),+$P($G(^IBA(362.4,+RXARR(IBX,IBY),0)),U,5),IBY)
. D ZERO^IBRXUTL(+$P(RXARR(IBX,IBY),U,2))
. S IBZ=$G(^TMP($J,"IBDRUG",+$P(RXARR(IBX,IBY),U,2),.01)),IBP=$$PRVNM(+RXARR(IBX,IBY))
. K ^TMP($J,"IBDRUG")
. W !,$J(IBI,2),")",?5,IBX,?19,$E(IBZ,1,25),?46,$$DATE^IBCSC5C(IBY),?56,$P(IBS,U,1),?61,$P(IBS,U,2),?69,$P(IBS,U,3)
. S IBZ=$$RXDUP^IBCU3(IBX,IBY,IBIFN) I +IBZ W ?73,$P($G(^DGCR(399,+IBZ,0)),U,1)
. S IBZ=$G(^DGCR(399,IBIFN,"RC",+$P(RXARR(IBX,IBY),U,7),0))
. W !,?5,$E(IBP,1,25),?35,"(Rx Procedure ",$S($P(IBZ,U,15):"#"_$P(IBZ,U,15)_" "_$$CPTNM^IBCRBH1(IBIFN,4,$P(IBZ,U,15)),1:"Missing")," Rev Code ",$S(IBZ:"#"_+$P(RXARR(IBX,IBY),U,7)_" "_$P($G(^DGCR(399.2,+IBZ,0)),U),1:"Missing"),")"
W !
Q
;
HELP(IFN) ;called for help from rx enter to display existing rx, displays rx' from 52 and 399
I +$G(IFN) N IBX,IBRXA S IBX=$$BILL(IFN) I +IBX D SET(IFN,.IBRXA,""),RXDISP^IBCSC5C($P(IBX,U,1),$P(IBX,U,2),$P(IBX,U,3),.IBPR,.IBPRO,.IBRXA,$P(IBX,U,4)) S IBRXAP=+IBPRO D SET(IFN,.IBRXA,.IBRXAP),DISP(.IBRXA,.IBRXAP)
Q
BILL(IBIFN) ; return data on a bill 'patient ifn ^ from dt ^ to dt ^ true if add original rx'
N IBX,IBY
S IBX=$G(^DGCR(399,+$G(IBIFN),0)),IBY=$P(IBX,U,2)
I '$$PERDIEM^IBCRU3(+$P(IBX,U,7),+$P(IBX,U,5),+$P(IBX,U,3)) S $P(IBY,U,4)=1
S IBX=$G(^DGCR(399,+IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2)
Q IBY
DRUG(IBD) ; get drug
N X,Y S IBD=+$G(IBD) S DIC(0)="VQ",DIC="^PSDRUG(" D DIC^PSSDI(50,"PS",.DIC,IBD,) I +Y<0 S IBD=0,DIC="^PSDRUG(",DIC(0)="AEQ" D DIC^PSSDI(50,"PS",.DIC,,) K DIC I +Y>0 S IBD=+Y
Q IBD
;
RCITEM(IBIFN,ARRAY,TYPE) ; Pull off all item charges from RC multiple
; for item TYPE on bill IBIFN, return array ARRAY
; If type = "ALL", pull off all types
;Set up @ARRAY@(type,item reference,ct)=# units^unit charge
; If no pointer to an item, this was a manually entered charge and
; will only 'associate' with the items found in the appropriate
; item source file that are not referenced by an item in the revenue
; code multiple in a sequential fashion (first unassociated 'RC' will
; correlate to the first unassociated entry found for the bill in source file)
N Z,Z0,Z1
S Z=0
F S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z S Z0=$G(^(Z,0)) I $S(TYPE="ALL":1,1:$P(Z0,U,10)=TYPE) I $P(Z0,U,10)'="" S Z1=$S($P(Z0,U,11)="":0,1:$P(Z0,U,11)),@ARRAY@($P(Z0,U,10),Z1,Z)=$P(Z0,U,3)_U_$P(Z0,U,2)
Q
;
FINDREV(IBIFN,TYP,PTR) ; Finds the first revenue code that matches the
; same item type and item pointer
;
N REVIEN,Z,Z0
S Z=0
F S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z S Z0=$G(^(Z,0)) I $P(Z0,U,10)=TYP,$P(Z0,U,11)=PTR S REVIEN=Z Q
Q $G(REVIEN)
;
NDCNUM(IBNDC) ; Returns the format of the NDC # IBNDC, if possible
N Z
S Z=$TR(IBNDC,"-")
Q $S(IBNDC?4N1"-"4N1"-"2N:1,IBNDC?5N1"-"3N1"-"2N:2,IBNDC?5N1"-"4N1"-"1N:3,IBNDC?5N1"-"4N1"-"2N!($L(Z)=11):4,IBNDC'="":1,1:"")
;
PRVNM(PIFN) ; return provider name for an rx, if one defined or null
N IBX,IBPRV,IBRXIFN S IBPRV=""
S IBRXIFN=$P($G(^IBA(362.4,+$G(PIFN),0)),U,5) I +IBRXIFN S IBX=$$FILE^IBRXUTL(IBRXIFN,4) I +IBX S IBPRV=$P($G(^VA(200,+IBX,0)),U,1)
Q IBPRV
ORDT(IBORDT,Y) ;get ISSUE DATE from file 52 and stuff into ORDER DATE of file 362.4
Q:IBORDT=""
N DIE,DA,DR
S DIE=362.4,DA=+Y,DR=".11///"_IBORDT D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC5A 8370 printed Oct 16, 2024@18:20:59 Page 2
IBCSC5A ;ALB/ARH - ADD/ENTER PRESCRIPTION FILLS ;12/27/93
+1 ;;2.0;INTEGRATED BILLING;**27,52,106,51,160,137,245,309,347,405,432**;21-MAR-94;Build 192
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN ;add/edit prescription fills for a bill, IBIFN required
+1 SET IBX=$$BILL(IBIFN)
if 'IBIFN
QUIT
SET DFN=+IBX
SET IBDT1=$PIECE(IBX,U,2)
SET IBDT2=$PIECE(IBX,U,3)
SET IBRXALL=$PIECE(IBX,U,4)
+2 DO SET(IBIFN,.IBRXA,"")
+3 DO RXDISP^IBCSC5C(DFN,IBDT1,IBDT2,.IBPR,.IBPRO,.IBRXA,IBRXALL)
IF +$PIECE($GET(IBPRO),U,2)
DO NEWRX^IBCSC5C(+IBPRO)
IF +$GET(IBLIST)
DO ADDNEW^IBCSC5C(IBIFN,IBLIST,.IBPR,.IBPRO)
SET DGRVRCAL=1
+4 SET IBRXAP=+$GET(IBPRO)
DO SET(IBIFN,.IBRXA,.IBRXAP)
DO DISP(.IBRXA,.IBRXAP)
E1 SET IBPIFN=0
SET IBRX=$$ASKRX(.IBRXAP,.IBPRO)
if IBRX=""
GOTO EXIT
SET IBDT=$PIECE(IBRX,U,2)
SET IBRX=$PIECE(IBRX,U,1)
SET DGRVRCAL=1
+1 IF 'IBDT
SET IBDT=$ORDER(IBRXA(IBRX,0))
if 'IBDT
SET IBDT=$ORDER(IBPR(IBRX,0))
SET IBDT=$$ASKDT(IBDT1,IBDT2,IBDT)
if 'IBDT
GOTO E1
+2 IF +$$RXDUP^IBCU3(IBRX,IBDT,IBIFN,1)
IF '$DATA(IBRXA(IBRX,IBDT))
GOTO E1
+3 IF '$DATA(IBPR(IBRX,IBDT))
WRITE !,"This rx fill does not exist in Pharmacy for this patient!",!
+4 SET IBPIFN=$GET(IBRXA(IBRX,IBDT))
SET IBDRG=$PIECE(IBPIFN,U,2)
+5 IF 'IBPIFN
SET IBX=$GET(IBPR(IBRX,IBDT))
SET IBPIFN=$$ADD(IBRX,IBIFN,IBDT,$PIECE(IBX,U,3),$PIECE(IBX,U,1),$PIECE(IBX,U,4,6),$PIECE(IBX,U,2))
Begin DoDot:1
+6 IF 'IBPIFN
WRITE " ??"
QUIT
+7 WRITE " ... ADDED"
End DoDot:1
if 'IBPIFN
GOTO E1
+8 DO EDIT(+IBPIFN,$PIECE(IBPIFN,U,7))
SET IBRXAP=+$GET(IBPRO)
DO SET(IBIFN,.IBRXA,.IBRXAP)
GOTO E1
+9 ;
EXIT ;
+1 KILL IBPIFN,IBRX,IBDRG,IBX,IBDT1,IBDT2,IBRXA,IBPR,IBDT,IBLIST,IBPRO,IBRXAP,IBRXALL
+2 QUIT
+3 ;
ASKRX(IBRXAP,IBPRO) ;
+1 NEW X,Y,IBY,IBX
WRITE !
SET IBX=""
+2 IF +$GET(IBIFN)
SET DIR("?")="The prescription number for the fill. "_$$HTEXT^IBCSC5C
SET DIR("??")="^D HELP^IBCSC5A("_IBIFN_")"
+3 SET DIR("A")="Select RX FILL"
SET DIR(0)="FO^1:11^K:X'?.UN X"
DO ^DIR
IF $DATA(DIRUT)!(Y'?.AN)
SET Y=""
KILL DIR,DIRUT
GOTO ARX1E
+4 SET IBX=Y
IF $DATA(IBRXAP)<10
IF $DATA(IBPRO)<10
GOTO ARX1E
+5 ;
+6 SET IBY=$GET(IBRXAP(IBX))
if IBY=""
SET IBY=$GET(IBPRO(IBX))
IF IBY=""
GOTO ARX1E
+7 WRITE !
SET DIR(0)="YO"
SET DIR("A")="ADD/EDIT RX FILL "_$PIECE(IBY,U,1)_" FOR "_$$FMTE^XLFDT($PIECE(IBY,U,2))_" CORRECT"
SET DIR("B")="YES"
+8 DO ^DIR
KILL DIR
IF Y=1
IF '$DATA(DIRUT)
SET IBX=IBY
ARX1E QUIT IBX
+1 ;
ASKDT(IBDT1,IBDT2,IBDT) ;
+1 SET DIR("A")="Select RX FILL DATE"
SET DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX"
SET DIR("B")=$$FMTE^XLFDT(IBDT)
DO ^DIR
KILL DIR,DTOUT,DIRUT
+2 QUIT $SELECT(Y?7N:Y,1:0)
+3 ;
ADD(RX,IFN,IBDT,DRUG,PIFN,OTHER,IBRF) ;
+1 NEW IBX,X,Y,DD,DO,DA,DIC,DLAYGO
+2 SET IBX=0
SET DRUG=$$DRUG($GET(DRUG))
if 'DRUG
GOTO ADDE
+3 SET DIC="^IBA(362.4,"
SET DIC(0)="AQL"
SET X=RX
SET DLAYGO=362.4
DO FILE^DICN
+4 IF Y>0
Begin DoDot:1
+5 ; IB *2.0*432 Stuff ISSUE DATE from file 52 when adding new RX to 362.4
+6 DO ORDT($PIECE(OTHER,U,4),+Y)
+7 SET DIE=DIC
SET (IBX,DA)=+Y
SET DR=".02////"_IFN_";.03////"_IBDT_";.04////"_DRUG_";.05////"_+PIFN_";.06////"_$PIECE(OTHER,U,1)_";.07////"_$PIECE(OTHER,U,2)_";.08////"_$PIECE(OTHER,U,3)
if $LENGTH($GET(IBRF))
SET DR=DR_";.1////"_IBRF
DO ^DIE
KILL DIE,DIC,DA,DR
+8 SET DGRVRCAL=1
End DoDot:1
ADDE QUIT IBX
+1 ;
EDIT(PIFN,REVIEN) ;
+1 NEW IBCHG,DIE,DR,DA,DIC,DIDEL,IBORDT
+2 ; IB*2.0*432 - display RX Order date to user, if available
+3 SET IBORDT=$PIECE($GET(^IBA(362.4,PIFN,0)),U,11)
+4 if IBORDT'=""
WRITE !,"Date RX Ordered: ",$$FMTE^XLFDT(IBORDT)
+5 SET DIDEL=362.4
SET DIE="^IBA(362.4,"
+6 SET DR=".01;.03;.04;.06;.07;.08;.09;.1"
+7 SET DA=PIFN
DO ^DIE
+8 ; Deleted RX - delete related rev code/CPT code
IF '$DATA(^IBA(362.4,PIFN,0))
IF $GET(REVIEN)
Begin DoDot:1
+9 IF $PIECE($GET(^DGCR(399,IBIFN,"RC",REVIEN,0)),U,15)
SET DA(1)=IBIFN
SET DA=$PIECE(^(0),U,15)
SET DIK="^DGCR(399,"_DA(1)_",""CP"","
DO ^DIK
+10 SET DA=REVIEN
SET DA(1)=IBIFN
SET DIK="^DGCR(399,"_DA(1)_",""RC"","
DO ^DIK
+11 SET DGRVRCAL=1
End DoDot:1
+12 QUIT
+13 ;
SET(IFN,RXARR,RXARRP) ;setup array of all rx fills for bill, array name should be passed by reference
+1 ;returns: RXARR(RX #, FILL DT)=RX IFN (362.4) ^ DRUG ^ DAYS SUPPLY ^ QTY ^ NDC # ^ Charge if known ^ ien of associated rev code multiple, if known ^ NDC FORMAT INDICATOR (1-4)^ORDER DATE
+2 ; RXARR=BILL IFN ^ RX count
+3 NEW CNT,IBX,IBY,IBZ,PIFN,IBC,IBCNT,IBRC
SET IBCNT=+$GET(RXARRP)
SET IBC="AIFN"_$GET(IFN)
KILL RXARR,RXARRP
+4 ;
+5 DO RCITEM(IFN,"IBRC",3)
+6 SET (CNT,IBX)=0
FOR
SET IBX=$ORDER(^IBA(362.4,IBC,IBX))
if IBX=""
QUIT
SET PIFN=0
FOR
SET PIFN=$ORDER(^IBA(362.4,IBC,IBX,PIFN))
if 'PIFN
QUIT
Begin DoDot:1
+7 SET IBY=$GET(^IBA(362.4,PIFN,0))
if IBY=""
QUIT
SET CNT=CNT+1
SET RXARR($PIECE(IBY,U,1),+$PIECE(IBY,U,3))=PIFN_U_$PIECE(IBY,U,4)_U_$PIECE(IBY,U,6,8)
SET $PIECE(RXARR($PIECE(IBY,U),+$PIECE(IBY,U,3)),U,6)=$$CHG^IBCF4(PIFN,3,.IBRC)
+8 IF $GET(IFN)
SET $PIECE(RXARR($PIECE(IBY,U),+$PIECE(IBY,U,3)),U,7)=$$FINDREV(IFN,3,PIFN)
+9 SET $PIECE(RXARR($PIECE(IBY,U),+$PIECE(IBY,U,3)),U,8)=$PIECE(IBY,U,9)
+10 ; IB *2.0*432 include ORDER DATE from file 362.4 in output formatter
+11 SET $PIECE(RXARR($PIECE(IBY,U),+$PIECE(IBY,U,3)),U,9)=$PIECE(IBY,U,11)
End DoDot:1
+12 ;
+13 SET RXARR=$GET(IFN)_"^"_CNT
+14 SET IBX=0
FOR
SET IBX=$ORDER(RXARR(IBX))
if IBX=""
QUIT
SET IBY=0
FOR
SET IBY=$ORDER(RXARR(IBX,IBY))
if 'IBY
QUIT
SET IBCNT=IBCNT+1
SET RXARRP(IBCNT)=IBX_"^"_IBY_"^"_$PIECE(RXARR(IBX,IBY),U,7)
+15 QUIT
+16 ;
DISP(RXARR,RXARRP) ;screen display of existing fills for a bill: input should be print order array returned by SET^IBCSC5A: RXARR(RX,DT)=RX IFN (362.4) ^ DRUG, passed by reference
+1 NEW IBX,IBY,IBZ,IBS,IBP,IBIFN
+2 WRITE !!,?5,"----------------- Existing Prescriptions on Bill -----------------",!
+3 SET IBIFN=+$GET(RXARR)
+4 SET IBI=0
FOR
SET IBI=$ORDER(RXARRP(IBI))
if IBI=""
QUIT
SET IBX=$PIECE(RXARRP(IBI),U,1)
SET IBY=$PIECE(RXARRP(IBI),U,2)
IF $DATA(RXARR(IBX,IBY))
Begin DoDot:1
+5 SET IBS=$$RXSTAT^IBCU1(+$PIECE(RXARR(IBX,IBY),U,2),+$PIECE($GET(^IBA(362.4,+RXARR(IBX,IBY),0)),U,5),IBY)
+6 DO ZERO^IBRXUTL(+$PIECE(RXARR(IBX,IBY),U,2))
+7 SET IBZ=$GET(^TMP($JOB,"IBDRUG",+$PIECE(RXARR(IBX,IBY),U,2),.01))
SET IBP=$$PRVNM(+RXARR(IBX,IBY))
+8 KILL ^TMP($JOB,"IBDRUG")
+9 WRITE !,$JUSTIFY(IBI,2),")",?5,IBX,?19,$EXTRACT(IBZ,1,25),?46,$$DATE^IBCSC5C(IBY),?56,$PIECE(IBS,U,1),?61,$PIECE(IBS,U,2),?69,$PIECE(IBS,U,3)
+10 SET IBZ=$$RXDUP^IBCU3(IBX,IBY,IBIFN)
IF +IBZ
WRITE ?73,$PIECE($GET(^DGCR(399,+IBZ,0)),U,1)
+11 SET IBZ=$GET(^DGCR(399,IBIFN,"RC",+$PIECE(RXARR(IBX,IBY),U,7),0))
+12 WRITE !,?5,$EXTRACT(IBP,1,25),?35,"(Rx Procedure ",$SELECT($PIECE(IBZ,U,15):"#"_$PIECE(IBZ,U,15)_" "_$$CPTNM^IBCRBH1(IBIFN,4,$PIECE(IBZ,U,15)),1:"Missing")," Rev Code ",...
... $SELECT(IBZ:"#"_+$PIECE(RXARR(IBX,IBY),U,7)_" "_$PIECE($GET(^DGCR(399.2,+IBZ,0)),U),1:"Missing"),")"
End DoDot:1
+13 WRITE !
+14 QUIT
+15 ;
HELP(IFN) ;called for help from rx enter to display existing rx, displays rx' from 52 and 399
+1 IF +$GET(IFN)
NEW IBX,IBRXA
SET IBX=$$BILL(IFN)
IF +IBX
DO SET(IFN,.IBRXA,"")
DO RXDISP^IBCSC5C($PIECE(IBX,U,1),$PIECE(IBX,U,2),$PIECE(IBX,U,3),.IBPR,.IBPRO,.IBRXA,$PIECE(IBX,U,4))
SET IBRXAP=+IBPRO
DO SET(IFN,.IBRXA,.IBRXAP)
DO DISP(.IBRXA,.IBRXAP)
+2 QUIT
BILL(IBIFN) ; return data on a bill 'patient ifn ^ from dt ^ to dt ^ true if add original rx'
+1 NEW IBX,IBY
+2 SET IBX=$GET(^DGCR(399,+$GET(IBIFN),0))
SET IBY=$PIECE(IBX,U,2)
+3 IF '$$PERDIEM^IBCRU3(+$PIECE(IBX,U,7),+$PIECE(IBX,U,5),+$PIECE(IBX,U,3))
SET $PIECE(IBY,U,4)=1
+4 SET IBX=$GET(^DGCR(399,+IBIFN,"U"))
SET $PIECE(IBY,U,2)=+IBX
SET $PIECE(IBY,U,3)=+$PIECE(IBX,U,2)
+5 QUIT IBY
DRUG(IBD) ; get drug
+1 NEW X,Y
SET IBD=+$GET(IBD)
SET DIC(0)="VQ"
SET DIC="^PSDRUG("
DO DIC^PSSDI(50,"PS",.DIC,IBD,)
IF +Y<0
SET IBD=0
SET DIC="^PSDRUG("
SET DIC(0)="AEQ"
DO DIC^PSSDI(50,"PS",.DIC,,)
KILL DIC
IF +Y>0
SET IBD=+Y
+2 QUIT IBD
+3 ;
RCITEM(IBIFN,ARRAY,TYPE) ; Pull off all item charges from RC multiple
+1 ; for item TYPE on bill IBIFN, return array ARRAY
+2 ; If type = "ALL", pull off all types
+3 ;Set up @ARRAY@(type,item reference,ct)=# units^unit charge
+4 ; If no pointer to an item, this was a manually entered charge and
+5 ; will only 'associate' with the items found in the appropriate
+6 ; item source file that are not referenced by an item in the revenue
+7 ; code multiple in a sequential fashion (first unassociated 'RC' will
+8 ; correlate to the first unassociated entry found for the bill in source file)
+9 NEW Z,Z0,Z1
+10 SET Z=0
+11 FOR
SET Z=$ORDER(^DGCR(399,IBIFN,"RC",Z))
if 'Z
QUIT
SET Z0=$GET(^(Z,0))
IF $SELECT(TYPE="ALL":1,1:$PIECE(Z0,U,10)=TYPE)
IF $PIECE(Z0,U,10)'=""
SET Z1=$SELECT($PIECE(Z0,U,11)="":0,1:$PIECE(Z0,U,11))
SET @ARRAY@($PIECE(Z0,U,10),Z1,Z)=$PIECE(Z0,U,3)_U_$PIECE(Z0,U,2)
+12 QUIT
+13 ;
FINDREV(IBIFN,TYP,PTR) ; Finds the first revenue code that matches the
+1 ; same item type and item pointer
+2 ;
+3 NEW REVIEN,Z,Z0
+4 SET Z=0
+5 FOR
SET Z=$ORDER(^DGCR(399,IBIFN,"RC",Z))
if 'Z
QUIT
SET Z0=$GET(^(Z,0))
IF $PIECE(Z0,U,10)=TYP
IF $PIECE(Z0,U,11)=PTR
SET REVIEN=Z
QUIT
+6 QUIT $GET(REVIEN)
+7 ;
NDCNUM(IBNDC) ; Returns the format of the NDC # IBNDC, if possible
+1 NEW Z
+2 SET Z=$TRANSLATE(IBNDC,"-")
+3 QUIT $SELECT(IBNDC?4N1"-"4N1"-"2N:1,IBNDC?5N1"-"3N1"-"2N:2,IBNDC?5N1"-"4N1"-"1N:3,IBNDC?5N1"-"4N1"-"2N!($LENGTH(Z)=11):4,IBNDC'="":1,1:"")
+4 ;
PRVNM(PIFN) ; return provider name for an rx, if one defined or null
+1 NEW IBX,IBPRV,IBRXIFN
SET IBPRV=""
+2 SET IBRXIFN=$PIECE($GET(^IBA(362.4,+$GET(PIFN),0)),U,5)
IF +IBRXIFN
SET IBX=$$FILE^IBRXUTL(IBRXIFN,4)
IF +IBX
SET IBPRV=$PIECE($GET(^VA(200,+IBX,0)),U,1)
+3 QUIT IBPRV
ORDT(IBORDT,Y) ;get ISSUE DATE from file 52 and stuff into ORDER DATE of file 362.4
+1 if IBORDT=""
QUIT
+2 NEW DIE,DA,DR
+3 SET DIE=362.4
SET DA=+Y
SET DR=".11///"_IBORDT
DO ^DIE
+4 QUIT
