IBARX1 ;ALB/AAS - INTEGRATED BILING, PHARMACY COPAY INTERFACE (CONT.) ; 21-FEB-91
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; - process 1 rx entry and accumulate totals
;
RX I $P(IBX,"^")'?1.N1":"1.N.ANP S Y="-1^IB012" G RXQ
I $P(IBX,"^",2)<1 S Y="-1^IB013" G RXQ
;
D BDESC
;
S DA=IBATYP D COST^IBAUTL S IBCHRG=$P(IBX,"^",2)*X1,IBTOTL=IBTOTL+IBCHRG
S IBWHER=2
D ADD^IBAUTL
I +Y<1 G RXQ
S IBPARNT=$S($D(IBPARNT):IBPARNT,1:IBN)
S $P(^IB(IBN,1),"^",1)=IBDUZ,$P(^IB(IBN,0),"^",2,13)=DFN_"^"_IBATYP_"^"_$P(IBX,"^")_"^2^"_$P(IBX,"^",2)_"^"_IBCHRG_"^"_IBDESC_"^"_IBPARNT_"^^"_IBIL_"^"_IBTRAN_"^"_IBFAC
K IBPARNT,^IB("AC",1,IBN) ;S ^IB("AC",2,IBN)=""
D INDEX
S IBSAVY(IBJ)=IBN_"^"_IBCHRG_"^"_IBIL
S:'$D(IBNOS) IBNOS="" S IBNOS=IBN_"^"_IBNOS
RXQ Q
;
CANRX ; - ibx = ibn for parent entry
; - ibn = new cancellation entry
S IBY(IBJ)=1
I '$D(^IBE(350.3,+$P(IBX,"^",2),0)) S (Y,IBY(IBJ))="-1^IB020" G CANRXQ
I '$D(^IB(+IBX,0)) S (Y,IBY(IBJ))="-1^IB021" G CANRXQ
S IBND=^IB(+IBX,0)
S IBCRES=$P(IBX,"^",2)
; -find most recent entry for parent ibx
; -if status isn't an update or new, error already cancelled?
D LAST I IBLAST'=IBPARNT,$D(^IB(IBLAST,0)),$P(^IBE(350.1,$P(^IB(IBLAST,0),"^",3),0),"^",5)=2 S (Y,IBY(IBJ))="-1^IB026^ Ref. No: "_+^IB(+IBLAST,0) G CANRXQ ;already cancelled
;
S IBPARNT=$P(IBND,"^",9) I '$D(^IB(IBPARNT,0)) S (Y,IBY(IBJ))="-1^IB027" G CANRXQ
S IBATYP=$P(^IBE(350.1,$P(IBND,"^",3),0),"^",6) ;cancellation action type for parent
I '$D(^IBE(350.1,+IBATYP,0)) S (Y,IBY(IBJ))="-1^IB022" G CANRXQ
S IBSEQNO=$P(^IBE(350.1,+IBATYP,0),"^",5) I 'IBSEQNO S (Y,IBY(IBJ))="-1^IB023" G CANRXQ
S IBIL=$P(IBND,"^",11) I IBIL="" S (Y,IBY(IBJ))="-1^IB024" G CANRXQ
S IBUNIT=$S($D(^IB(+IBLAST,0)):$P(^(0),"^",6),1:$P(IBND,"^",6)) I IBUNIT<1 S (Y,IBY(IBJ))="-1^IB025" G CANRXQ
S DA=IBATYP D COST^IBAUTL S IBCHRG=IBUNIT*X1,IBTOTL=IBTOTL+IBCHRG
S IBWHER=2
D ADD^IBAUTL I +Y<1 S IBY(IBJ)=Y G CANRXQ
S $P(^IB(IBN,1),"^",1)=IBDUZ,$P(^IB(IBN,0),"^",2,13)=DFN_"^"_IBATYP_"^"_$P(IBND,"^",4)_"^2^"_IBUNIT_"^"_IBCHRG_"^"_$P(IBND,"^",8)_"^"_IBPARNT_"^"_IBCRES_"^"_IBIL_"^^"_IBFAC
K ^IB("AC",1,IBN) ;S ^IB("AC",2,IBN)=""
D INDEX
S Y(IBJ)=IBN_"^"_IBCHRG_"^"_IBIL
S IBNOS=IBN
CANRXQ Q
;
BDESC ; -return brief description
N X,Y S IBDESC="",X=$P(IBX,"^")
I $D(^IBE(350.1,IBATYP,20)) X ^(20) S IBDESC=X
Q
LAST ;find last entry
S IBLAST=""
S IBPARNT=$P(^IB(+IBX,0),"^",9) I 'IBPARNT S IBPARNT=+IBX
S IBLDT=$O(^IB("APDT",IBPARNT,"")) I +IBLDT F IBL=0:0 S IBL=$O(^IB("APDT",IBPARNT,IBLDT,IBL)) Q:'IBL S IBLAST=IBL
I IBLAST="" S IBLAST=IBPARNT
Q
;
INDEX ;cross-reference entry
N X,Y
S DA=IBN,DIK="^IB(" D IX^DIK
K DIK Q
;
SERV(Y) ; -- Service check for Pharmacy
; called by the screen in the input transform for the IB SERVICE/SECTION
; field of the PHARMACY SITE file.
; input = Y internal entry number in service section file
; output = 1 if okay to use (service matches) or 0 if not okay
;
; -- screen logic for field 1003 in file 59.9 should be
; S DIC("S")="I $$SERV^IBARX1(+Y)"
;
Q $S('$G(Y):0,1:$D(^IBE(350.1,"ANEW",Y,1,1))&$D(^IBE(350.1,"ANEW",Y,1,2)))
IBARX1 ;ALB/AAS - INTEGRATED BILING, PHARMACY COPAY INTERFACE (CONT.) ; 21-FEB-91
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; - process 1 rx entry and accumulate totals
+5 ;
RX IF $PIECE(IBX,"^")'?1.N1":"1.N.ANP
SET Y="-1^IB012"
GOTO RXQ
+1 IF $PIECE(IBX,"^",2)<1
SET Y="-1^IB013"
GOTO RXQ
+2 ;
+3 DO BDESC
+4 ;
+5 SET DA=IBATYP
DO COST^IBAUTL
SET IBCHRG=$PIECE(IBX,"^",2)*X1
SET IBTOTL=IBTOTL+IBCHRG
+6 SET IBWHER=2
+7 DO ADD^IBAUTL
+8 IF +Y<1
GOTO RXQ
+9 SET IBPARNT=$SELECT($DATA(IBPARNT):IBPARNT,1:IBN)
+10 SET $PIECE(^IB(IBN,1),"^",1)=IBDUZ
SET $PIECE(^IB(IBN,0),"^",2,13)=DFN_"^"_IBATYP_"^"_$PIECE(IBX,"^")_"^2^"_$PIECE(IBX,"^",2)_"^"_IBCHRG_"^"_IBDESC_"^"_IBPARNT_"^^"_IBIL_"^"_IBTRAN_"^"_IBFAC
+11 ;S ^IB("AC",2,IBN)=""
KILL IBPARNT,^IB("AC",1,IBN)
+12 DO INDEX
+13 SET IBSAVY(IBJ)=IBN_"^"_IBCHRG_"^"_IBIL
+14 IF '$DATA(IBNOS)
SET IBNOS=""
SET IBNOS=IBN_"^"_IBNOS
RXQ QUIT
+1 ;
CANRX ; - ibx = ibn for parent entry
+1 ; - ibn = new cancellation entry
+2 SET IBY(IBJ)=1
+3 IF '$DATA(^IBE(350.3,+$PIECE(IBX,"^",2),0))
SET (Y,IBY(IBJ))="-1^IB020"
GOTO CANRXQ
+4 IF '$DATA(^IB(+IBX,0))
SET (Y,IBY(IBJ))="-1^IB021"
GOTO CANRXQ
+5 SET IBND=^IB(+IBX,0)
+6 SET IBCRES=$PIECE(IBX,"^",2)
+7 ; -find most recent entry for parent ibx
+8 ; -if status isn't an update or new, error already cancelled?
+9 ;already cancelled
DO LAST
IF IBLAST'=IBPARNT
IF $DATA(^IB(IBLAST,0))
IF $PIECE(^IBE(350.1,$PIECE(^IB(IBLAST,0),"^",3),0),"^",5)=2
SET (Y,IBY(IBJ))="-1^IB026^ Ref. No: "_+^IB(+IBLAST,0)
GOTO CANRXQ
+10 ;
+11 SET IBPARNT=$PIECE(IBND,"^",9)
IF '$DATA(^IB(IBPARNT,0))
SET (Y,IBY(IBJ))="-1^IB027"
GOTO CANRXQ
+12 ;cancellation action type for parent
SET IBATYP=$PIECE(^IBE(350.1,$PIECE(IBND,"^",3),0),"^",6)
+13 IF '$DATA(^IBE(350.1,+IBATYP,0))
SET (Y,IBY(IBJ))="-1^IB022"
GOTO CANRXQ
+14 SET IBSEQNO=$PIECE(^IBE(350.1,+IBATYP,0),"^",5)
IF 'IBSEQNO
SET (Y,IBY(IBJ))="-1^IB023"
GOTO CANRXQ
+15 SET IBIL=$PIECE(IBND,"^",11)
IF IBIL=""
SET (Y,IBY(IBJ))="-1^IB024"
GOTO CANRXQ
+16 SET IBUNIT=$SELECT($DATA(^IB(+IBLAST,0)):$PIECE(^(0),"^",6),1:$PIECE(IBND,"^",6))
IF IBUNIT<1
SET (Y,IBY(IBJ))="-1^IB025"
GOTO CANRXQ
+17 SET DA=IBATYP
DO COST^IBAUTL
SET IBCHRG=IBUNIT*X1
SET IBTOTL=IBTOTL+IBCHRG
+18 SET IBWHER=2
+19 DO ADD^IBAUTL
IF +Y<1
SET IBY(IBJ)=Y
GOTO CANRXQ
+20 SET $PIECE(^IB(IBN,1),"^",1)=IBDUZ
SET $PIECE(^IB(IBN,0),"^",2,13)=DFN_"^"_IBATYP_"^"_$PIECE(IBND,"^",4)_"^2^"_IBUNIT_"^"_IBCHRG_"^"_$PIECE(IBND,"^",8)_"^"_IBPARNT_"^"_IBCRES_"^"_IBIL_"^^"_IBFAC
+21 ;S ^IB("AC",2,IBN)=""
KILL ^IB("AC",1,IBN)
+22 DO INDEX
+23 SET Y(IBJ)=IBN_"^"_IBCHRG_"^"_IBIL
+24 SET IBNOS=IBN
CANRXQ QUIT
+1 ;
BDESC ; -return brief description
+1 NEW X,Y
SET IBDESC=""
SET X=$PIECE(IBX,"^")
+2 IF $DATA(^IBE(350.1,IBATYP,20))
XECUTE ^(20)
SET IBDESC=X
+3 QUIT
LAST ;find last entry
+1 SET IBLAST=""
+2 SET IBPARNT=$PIECE(^IB(+IBX,0),"^",9)
IF 'IBPARNT
SET IBPARNT=+IBX
+3 SET IBLDT=$ORDER(^IB("APDT",IBPARNT,""))
IF +IBLDT
FOR IBL=0:0
SET IBL=$ORDER(^IB("APDT",IBPARNT,IBLDT,IBL))
IF 'IBL
QUIT
SET IBLAST=IBL
+4 IF IBLAST=""
SET IBLAST=IBPARNT
+5 QUIT
+6 ;
INDEX ;cross-reference entry
+1 NEW X,Y
+2 SET DA=IBN
SET DIK="^IB("
DO IX^DIK
+3 KILL DIK
QUIT
+4 ;
SERV(Y) ; -- Service check for Pharmacy
+1 ; called by the screen in the input transform for the IB SERVICE/SECTION
+2 ; field of the PHARMACY SITE file.
+3 ; input = Y internal entry number in service section file
+4 ; output = 1 if okay to use (service matches) or 0 if not okay
+5 ;
+6 ; -- screen logic for field 1003 in file 59.9 should be
+7 ; S DIC("S")="I $$SERV^IBARX1(+Y)"
+8 ;
+9 QUIT $SELECT('$GET(Y):0,1:$DATA(^IBE(350.1,"ANEW",Y,1,1))&$DATA(^IBE(350.1,"ANEW",Y,1,2)))
