- 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 Jan 18, 2025@03:08:44 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 ;