IBARXMA ;LL/ELZ - PHARMCAY COPAY BACKGROUND PROCESSES ; 02 Mar 2021
;;2.0;INTEGRATED BILLING;**150,158,676**;21-MAR-94;Build 34
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
FILER(IBA) ; This label is called by the IB background filer to
; notify other facilities that a transaction has occurred on the current
; facility. It will then update the status in 354.71 assuming that the
; transaction was accepted at all the subscribing facilities.
;
; IBA would be the IEN of file 350 to process.
;
N IBZ,IBY,Y,IBER
;
S IBZ=$P($G(^IB(+IBA,0)),"^",19) I 'IBZ Q
S $P(^IBAM(354.71,IBZ,0),"^",4)=+IBA ; set reference back
;
S IBY=1 D FOUND(.IBY,IBZ)
;
I -1=+$G(IBY) S Y=IBY D ^IBAERR
;
Q
;
FOUND(IBY,IBZ) ; come in here to do the work
;
; ien in 354.71 stored in IBZ, assumes DFN is defined
;
N IBTFL,IBX,IBT,X,Y,DIE,DA,DR,DIC,IBS,IBD
;
; get treating facility list
S IBTFL=$$TFL^IBARXMU(DFN,.IBTFL,2)
;
; No other facilities, I'm done
I 'IBTFL D STATUS(.IBY,IBZ,0) Q
;
; ok lets do some talking to other VA's
S IBX=0 F S IBX=$O(IBTFL(IBX)) Q:IBX<1!(IBY<1) D
. ;
. ; have I already completed transmission here?
. S IBS=$$LKUP^XUAF4($P(IBTFL(IBX),"^")) ;676;BL Modify the call to use full station number
. I IBS>0,$P($G(^IBAM(354.71,IBZ,1,+$O(^IBAM(354.71,IBZ,1,"B",+IBS,0)),0)),"^",2),'$G(IBONE) Q
. ;
. I '$D(ZTQUEUED) U IO W !,"Now transmitting to ",$P(IBTFL(IBX),"^",2)," ..."
. D ;Determine if Cerner, use HL7 send
. . I $P(IBTFL(IBX),"^",1)["200CRNR" D Q
. . . D EN^IBARXCHL(DFN,IBZ)
. . . S IBT=1 ;Assume send was successful
. . S IBT=$$SEND^IBARXMU(DFN,IBX,^IBAM(354.71,IBZ,0))
. ;
. ; update 354.71 transmission record
. S DA=$O(^IBAM(354.71,IBZ,1,"B",IBS,0)),DA(1)=IBZ
. ;
. ; save of error(s) for message
. S:IBT<1 IBER(IBX)=IBT
. ;
. I DA D Q
.. S DIE="^IBAM(354.71,"_IBZ_",1,",DR=".02////"_$S(+IBT>0:1,1:0)
.. L +^IBAM(354.71,IBZ,1,DA):10 I '$T S IBY="-1^IB318" Q
.. D ^DIE L -^IBAM(354.71,IBZ,1,DA)
. S DIC="^IBAM(354.71,"_IBZ_",1,",DIC(0)="",X=IBS
. S DIC("DR")=".02////"_$S(IBT>0:1,1:0) D FILE^DICN
;
D STATUS(.IBY,IBZ,IBTFL):IBY>0
;
Q
;
NIGHT ; queue off job to do nightly processing
N IOP,ZTIO,ZTSAVE,ZTRTN,ZTDESC,ZTASK,%ZIS,ZTDTH
S ZTIO="",ZTRTN="NIGHTQ^IBARXMA",ZTDTH=$H,ZTDESC="RX Copay Cap Follow-up Transmissions"
D ^%ZTLOAD
Q
;
NIGHTQ ; called from nightly background job for transmissions
;
N IBX,IBS,X
;
F IBS="P","Y" S IBX=0 F S IBX=$O(^IBAM(354.71,"AC",IBS,IBX)) Q:IBX<1 D
. N IBY,IBZ,IBM,XMZ,XMY,XMDUZ,XMSUB,IBL,IBF,IBT,DFN,IBA,IBN,IBER S IBY=1
. ;
. S DFN=$P($G(^IBAM(354.71,+IBX,0)),"^",2) Q:'DFN
. S IBY=1 D FOUND(.IBY,IBX)
. ;
. ; if it is successful, quit and move on to next one
. S IBZ=^IBAM(354.71,IBX,0)
. I IBY>0,($P(IBZ,"^",5)="C"!($P(IBZ,"^",5)="X")) Q
. ;
. ; is the transaction < 2 days old, quit
. I $$FMADD^XLFDT($P(IBZ,"^",15),2)>DT Q
. ;
. ; send message to mail group of old transaction notification
. D DEM^VADPT
. S XMSUB="Rx Copay Transmission Error",XMDUZ="INTEGRATED BILLING PACKAGE" D XMZ^XMA2 I XMZ<1 Q
. S IBL=0
. D M("A medication co-payment transaction could not be sent to one or more of"),M("the patient's treating facilities for at least 2 days. After verifying that")
. D M("the HL7 Logical Links are working correctly to the sites listed below, you"),M("can use the option 'Push Rx Copay Cap Transactions' to transmit this")
. D M("transaction immediately or the IB software will try to transmit this"),M("transaction when the IB MT NIGHT COMP job runs.")
. D M(" "),M(" Patient: "_VADM(1)),M(" SSN: "_VA("PID")),M("Transaction: "_$P(IBZ,"^")),M(" ")
. D M("Facility Status"),M("----------------------------------- --------------------")
. S IBF=0 F S IBF=$O(^IBAM(354.71,IBX,1,IBF)) Q:IBF<1 S IBT=^IBAM(354.71,IBX,1,IBF,0),IBN=$$FAC^IBARXMU(+IBT),IBN=$P(IBN,"^")_" ("_$P(IBN,"^",2)_")" D
.. D M($$SP(IBN,39)_$$EXTERNAL^DILFD(354.711,.02,"",$P(IBT,"^",2)))
. ;
. ; include errors in message
. I $D(IBER) D M(" "),M("Errors:") S X=0 F S X=$O(IBER(X)) Q:X<1 D M(X_" = "_IBER(X))
. ;
. S ^XMB(3.9,XMZ,2,0)="^3.92^"_IBL_"^"_IBL_"^"_DT
. S XMY("G.IB RX COPAY CAP ERROR")=""
. D ENT1^XMD
Q
;
SP(X,Y) ; makes X be Y space long
F Q:$L(X)>(Y-1) S X=X_" "
Q $E(X,1,Y)
;
STATUS(IBY,IBZ,IBT) ; update status in 354.71 if applicable
; IBY is return error if applicable
; IBZ is the entry number in 354.71
; IBT indicates number of treating facilities
;
N IBS,IBX,DA,DIE,DR,X,Y,IBD
;
S IBS=1,IBX=0 I IBT F S IBX=$O(^IBAM(354.71,IBZ,1,IBX)) Q:IBX<1 S:$P(^IBAM(354.71,IBZ,1,IBX,0),"^",2)'=1 IBS=0
;
I IBS S IBD=$P(^IBAM(354.71,IBZ,0),"^",5) D
. S DIE="^IBAM(354.71,",DA=IBZ
. S DR=".05///"_$S(IBD="Y":"X",IBD="X":IBD,1:"C")
. L +^IBAM(354.71,IBZ):10 I '$T S IBY="-1^IB318" Q
. D ^DIE L -^IBAM(354.71,IBZ)
;
I $G(IBY)<1 S IBY=1 ; success flag
;
Q
M(T) ; used to set text in mail message
; assumes XMZ and IBL
S IBL=IBL+1,^XMB(3.9,XMZ,2,IBL,0)=T
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXMA 5133 printed Apr 09, 2024@21:22:59 Page 2
IBARXMA ;LL/ELZ - PHARMCAY COPAY BACKGROUND PROCESSES ; 02 Mar 2021
+1 ;;2.0;INTEGRATED BILLING;**150,158,676**;21-MAR-94;Build 34
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
FILER(IBA) ; This label is called by the IB background filer to
+1 ; notify other facilities that a transaction has occurred on the current
+2 ; facility. It will then update the status in 354.71 assuming that the
+3 ; transaction was accepted at all the subscribing facilities.
+4 ;
+5 ; IBA would be the IEN of file 350 to process.
+6 ;
+7 NEW IBZ,IBY,Y,IBER
+8 ;
+9 SET IBZ=$PIECE($GET(^IB(+IBA,0)),"^",19)
IF 'IBZ
QUIT
+10 ; set reference back
SET $PIECE(^IBAM(354.71,IBZ,0),"^",4)=+IBA
+11 ;
+12 SET IBY=1
DO FOUND(.IBY,IBZ)
+13 ;
+14 IF -1=+$GET(IBY)
SET Y=IBY
DO ^IBAERR
+15 ;
+16 QUIT
+17 ;
FOUND(IBY,IBZ) ; come in here to do the work
+1 ;
+2 ; ien in 354.71 stored in IBZ, assumes DFN is defined
+3 ;
+4 NEW IBTFL,IBX,IBT,X,Y,DIE,DA,DR,DIC,IBS,IBD
+5 ;
+6 ; get treating facility list
+7 SET IBTFL=$$TFL^IBARXMU(DFN,.IBTFL,2)
+8 ;
+9 ; No other facilities, I'm done
+10 IF 'IBTFL
DO STATUS(.IBY,IBZ,0)
QUIT
+11 ;
+12 ; ok lets do some talking to other VA's
+13 SET IBX=0
FOR
SET IBX=$ORDER(IBTFL(IBX))
if IBX<1!(IBY<1)
QUIT
Begin DoDot:1
+14 ;
+15 ; have I already completed transmission here?
+16 ;676;BL Modify the call to use full station number
SET IBS=$$LKUP^XUAF4($PIECE(IBTFL(IBX),"^"))
+17 IF IBS>0
IF $PIECE($GET(^IBAM(354.71,IBZ,1,+$ORDER(^IBAM(354.71,IBZ,1,"B",+IBS,0)),0)),"^",2)
IF '$GET(IBONE)
QUIT
+18 ;
+19 IF '$DATA(ZTQUEUED)
USE IO
WRITE !,"Now transmitting to ",$PIECE(IBTFL(IBX),"^",2)," ..."
+20 ;Determine if Cerner, use HL7 send
Begin DoDot:2
+21 IF $PIECE(IBTFL(IBX),"^",1)["200CRNR"
Begin DoDot:3
+22 DO EN^IBARXCHL(DFN,IBZ)
+23 ;Assume send was successful
SET IBT=1
End DoDot:3
QUIT
+24 SET IBT=$$SEND^IBARXMU(DFN,IBX,^IBAM(354.71,IBZ,0))
End DoDot:2
+25 ;
+26 ; update 354.71 transmission record
+27 SET DA=$ORDER(^IBAM(354.71,IBZ,1,"B",IBS,0))
SET DA(1)=IBZ
+28 ;
+29 ; save of error(s) for message
+30 if IBT<1
SET IBER(IBX)=IBT
+31 ;
+32 IF DA
Begin DoDot:2
+33 SET DIE="^IBAM(354.71,"_IBZ_",1,"
SET DR=".02////"_$SELECT(+IBT>0:1,1:0)
+34 LOCK +^IBAM(354.71,IBZ,1,DA):10
IF '$TEST
SET IBY="-1^IB318"
QUIT
+35 DO ^DIE
LOCK -^IBAM(354.71,IBZ,1,DA)
End DoDot:2
QUIT
+36 SET DIC="^IBAM(354.71,"_IBZ_",1,"
SET DIC(0)=""
SET X=IBS
+37 SET DIC("DR")=".02////"_$SELECT(IBT>0:1,1:0)
DO FILE^DICN
End DoDot:1
+38 ;
+39 if IBY>0
DO STATUS(.IBY,IBZ,IBTFL)
+40 ;
+41 QUIT
+42 ;
NIGHT ; queue off job to do nightly processing
+1 NEW IOP,ZTIO,ZTSAVE,ZTRTN,ZTDESC,ZTASK,%ZIS,ZTDTH
+2 SET ZTIO=""
SET ZTRTN="NIGHTQ^IBARXMA"
SET ZTDTH=$HOROLOG
SET ZTDESC="RX Copay Cap Follow-up Transmissions"
+3 DO ^%ZTLOAD
+4 QUIT
+5 ;
NIGHTQ ; called from nightly background job for transmissions
+1 ;
+2 NEW IBX,IBS,X
+3 ;
+4 FOR IBS="P","Y"
SET IBX=0
FOR
SET IBX=$ORDER(^IBAM(354.71,"AC",IBS,IBX))
if IBX<1
QUIT
Begin DoDot:1
+5 NEW IBY,IBZ,IBM,XMZ,XMY,XMDUZ,XMSUB,IBL,IBF,IBT,DFN,IBA,IBN,IBER
SET IBY=1
+6 ;
+7 SET DFN=$PIECE($GET(^IBAM(354.71,+IBX,0)),"^",2)
if 'DFN
QUIT
+8 SET IBY=1
DO FOUND(.IBY,IBX)
+9 ;
+10 ; if it is successful, quit and move on to next one
+11 SET IBZ=^IBAM(354.71,IBX,0)
+12 IF IBY>0
IF ($PIECE(IBZ,"^",5)="C"!($PIECE(IBZ,"^",5)="X"))
QUIT
+13 ;
+14 ; is the transaction < 2 days old, quit
+15 IF $$FMADD^XLFDT($PIECE(IBZ,"^",15),2)>DT
QUIT
+16 ;
+17 ; send message to mail group of old transaction notification
+18 DO DEM^VADPT
+19 SET XMSUB="Rx Copay Transmission Error"
SET XMDUZ="INTEGRATED BILLING PACKAGE"
DO XMZ^XMA2
IF XMZ<1
QUIT
+20 SET IBL=0
+21 DO M("A medication co-payment transaction could not be sent to one or more of")
DO M("the patient's treating facilities for at least 2 days. After verifying that")
+22 DO M("the HL7 Logical Links are working correctly to the sites listed below, you")
DO M("can use the option 'Push Rx Copay Cap Transactions' to transmit this")
+23 DO M("transaction immediately or the IB software will try to transmit this")
DO M("transaction when the IB MT NIGHT COMP job runs.")
+24 DO M(" ")
DO M(" Patient: "_VADM(1))
DO M(" SSN: "_VA("PID"))
DO M("Transaction: "_$PIECE(IBZ,"^"))
DO M(" ")
+25 DO M("Facility Status")
DO M("----------------------------------- --------------------")
+26 SET IBF=0
FOR
SET IBF=$ORDER(^IBAM(354.71,IBX,1,IBF))
if IBF<1
QUIT
SET IBT=^IBAM(354.71,IBX,1,IBF,0)
SET IBN=$$FAC^IBARXMU(+IBT)
SET IBN=$PIECE(IBN,"^")_" ("_$PIECE(IBN,"^",2)_")"
Begin DoDot:2
+27 DO M($$SP(IBN,39)_$$EXTERNAL^DILFD(354.711,.02,"",$PIECE(IBT,"^",2)))
End DoDot:2
+28 ;
+29 ; include errors in message
+30 IF $DATA(IBER)
DO M(" ")
DO M("Errors:")
SET X=0
FOR
SET X=$ORDER(IBER(X))
if X<1
QUIT
DO M(X_" = "_IBER(X))
+31 ;
+32 SET ^XMB(3.9,XMZ,2,0)="^3.92^"_IBL_"^"_IBL_"^"_DT
+33 SET XMY("G.IB RX COPAY CAP ERROR")=""
+34 DO ENT1^XMD
End DoDot:1
+35 QUIT
+36 ;
SP(X,Y) ; makes X be Y space long
+1 FOR
if $LENGTH(X)>(Y-1)
QUIT
SET X=X_" "
+2 QUIT $EXTRACT(X,1,Y)
+3 ;
STATUS(IBY,IBZ,IBT) ; update status in 354.71 if applicable
+1 ; IBY is return error if applicable
+2 ; IBZ is the entry number in 354.71
+3 ; IBT indicates number of treating facilities
+4 ;
+5 NEW IBS,IBX,DA,DIE,DR,X,Y,IBD
+6 ;
+7 SET IBS=1
SET IBX=0
IF IBT
FOR
SET IBX=$ORDER(^IBAM(354.71,IBZ,1,IBX))
if IBX<1
QUIT
if $PIECE(^IBAM(354.71,IBZ,1,IBX,0),"^",2)'=1
SET IBS=0
+8 ;
+9 IF IBS
SET IBD=$PIECE(^IBAM(354.71,IBZ,0),"^",5)
Begin DoDot:1
+10 SET DIE="^IBAM(354.71,"
SET DA=IBZ
+11 SET DR=".05///"_$SELECT(IBD="Y":"X",IBD="X":IBD,1:"C")
+12 LOCK +^IBAM(354.71,IBZ):10
IF '$TEST
SET IBY="-1^IB318"
QUIT
+13 DO ^DIE
LOCK -^IBAM(354.71,IBZ)
End DoDot:1
+14 ;
+15 ; success flag
IF $GET(IBY)<1
SET IBY=1
+16 ;
+17 QUIT
M(T) ; used to set text in mail message
+1 ; assumes XMZ and IBL
+2 SET IBL=IBL+1
SET ^XMB(3.9,XMZ,2,IBL,0)=T
+3 ;
