- IBARXEB ;ALB/AAS - RX COPAY EXEMPTION BULLETIN PROCESSOR ; 15-JAN-93
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- % N IBP,IBALERT
- Q:IBEVTP="" ; no prior exemption
- Q:IBEVTP=IBEVTA
- S IBCODA=$$ACODE^IBARXEU0(IBEVTA),IBCODP=$$ACODE^IBARXEU0(IBEVTP)
- Q:$L(IBCODA)=2 ; -went to automatic exemption
- ;
- K IBT
- I IBCODA=2010 D ; -went to hardship
- .S IBALERT=1
- .S IBT(9)="Patient has been given a Hardship Exemption."
- .Q
- I IBCODP=2010 D ; -went from hardship
- .S IBALERT=2
- .S IBT(9)="Patient's Hardship exemption has been removed."
- .Q
- I IBCODA=210,$L(IBCODP)=3,$P(IBEVTP,"^",4)=1 D ; -went to no income data from exempt income
- .S IBALERT=3
- .S IBT(9)="Patient's exemption based on Income has expired."
- .Q
- ;
- Q:'$D(IBT) ; no alert needed
- ;
- S IBP=$$PT^IBEFUNC(DFN)
- I $$ALERT^IBAUTL7 D SEND^IBAERR3 G BQ
- D BULL
- BQ K IBEXERR Q
- ;
- ALERT ; -- use kernel alerts
- ;
- ALERTQ Q
- ;
- BULL ; -- send bulletin
- ;
- S XMSUB="Medication Copayment Exemption Status Change"
- S IBT(1)="The following Patient's Medication Copayment Exemption Status has changed:"
- S IBT(2)=" Patient: "_$E($P(IBP,"^")_" ",1,25)_" PT. ID: "_$P(IBP,"^",2)
- S IBT(3)=""
- S IBT(4)=" Old Status: "_$E($$TEXT^IBARXEU0($P(IBEVTP,"^",4))_" ",1,10)_" - "_$P($G(^IBE(354.2,+$P(IBEVTP,"^",5),0)),"^")_" Dated "_$$DAT1^IBOUTL(+IBEVTP)
- S IBT(5)=" New Status: "_$E($$TEXT^IBARXEU0($P(IBEVTA,"^",4))_" ",1,10)_" - "_$P($G(^IBE(354.2,+$P(IBEVTA,"^",5),0)),"^")_" Dated "_$$DAT1^IBOUTL(+IBEVTA)
- S IBT(6)="" I $D(IBARCAN) S IBT(6)="Past charges were canceled in AR."
- S IBT(7)=""
- S IBT(8)=""
- S IBT(10)=" by: "_$P($G(^VA(200,+$P(IBEVTA,"^",7),0)),"^")_"/"_$S($P(IBEVTA,"^",6)=1:"(System)",1:"(Manual)")
- S Y=$P(IBEVTA,"^",8) D D^DIQ S IBT(11)=" on: "_$P(Y,"@")_" @ "_$P(Y,"@",2)
- S IBT(12)="Option: " I $D(XQY0) S IBT(12)=IBT(12)_$P($G(XQY0),"^",2)
- I $D(ZTQUEUED),$P($G(XQY0),"^",2)="" S IBT(12)=IBT(12)_"Queued Job - "_$G(ZTDESC)
- D SEND
- BULLQ Q
- ;
- SEND S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="IBT("
- K XMY S XMN=0
- ;S XMY(DUZ)="" ;don't send to user, is annoying to pharmacy.
- S IBGRP=$P($G(^XMB(3.8,+$P($G(^IBE(350.9,1,0)),"^",13),0)),"^")
- I IBGRP]"" S XMY("G."_IBGRP_"@"_^XMB("NETNAME"))=""
- ;S IBGRP=$P(^IBE(350.9,1,0),"^",9)
- ;F IBI=0:0 S IBI=$O(^XMB(3.8,+IBGRP,1,"B",IBI)) Q:'IBI S XMY(IBI)=""
- D ^XMD
- K X,Y,IBI,IBT,IBGRP,XMDUZ,XMTEXT,XMY,XMSUB
- Q
- IBARXEB ;ALB/AAS - RX COPAY EXEMPTION BULLETIN PROCESSOR ; 15-JAN-93
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- % NEW IBP,IBALERT
- +1 ; no prior exemption
- IF IBEVTP=""
- QUIT
- +2 IF IBEVTP=IBEVTA
- QUIT
- +3 SET IBCODA=$$ACODE^IBARXEU0(IBEVTA)
- SET IBCODP=$$ACODE^IBARXEU0(IBEVTP)
- +4 ; -went to automatic exemption
- IF $LENGTH(IBCODA)=2
- QUIT
- +5 ;
- +6 KILL IBT
- +7 ; -went to hardship
- IF IBCODA=2010
- Begin DoDot:1
- +8 SET IBALERT=1
- +9 SET IBT(9)="Patient has been given a Hardship Exemption."
- +10 QUIT
- End DoDot:1
- +11 ; -went from hardship
- IF IBCODP=2010
- Begin DoDot:1
- +12 SET IBALERT=2
- +13 SET IBT(9)="Patient's Hardship exemption has been removed."
- +14 QUIT
- End DoDot:1
- +15 ; -went to no income data from exempt income
- IF IBCODA=210
- IF $LENGTH(IBCODP)=3
- IF $PIECE(IBEVTP,"^",4)=1
- Begin DoDot:1
- +16 SET IBALERT=3
- +17 SET IBT(9)="Patient's exemption based on Income has expired."
- +18 QUIT
- End DoDot:1
- +19 ;
- +20 ; no alert needed
- IF '$DATA(IBT)
- QUIT
- +21 ;
- +22 SET IBP=$$PT^IBEFUNC(DFN)
- +23 IF $$ALERT^IBAUTL7
- DO SEND^IBAERR3
- GOTO BQ
- +24 DO BULL
- BQ KILL IBEXERR
- QUIT
- +1 ;
- ALERT ; -- use kernel alerts
- +1 ;
- ALERTQ QUIT
- +1 ;
- BULL ; -- send bulletin
- +1 ;
- +2 SET XMSUB="Medication Copayment Exemption Status Change"
- +3 SET IBT(1)="The following Patient's Medication Copayment Exemption Status has changed:"
- +4 SET IBT(2)=" Patient: "_$EXTRACT($PIECE(IBP,"^")_" ",1,25)_" PT. ID: "_$PIECE(IBP,"^",2)
- +5 SET IBT(3)=""
- +6 SET IBT(4)=" Old Status: "_$EXTRACT($$TEXT^IBARXEU0($PIECE(IBEVTP,"^",4))_" ",1,10)_" - "_$PIECE($GET(^IBE(354.2,+$PIECE(IBEVTP,"^",5),0)),"^")_" Dated "_$$DAT1^IBOUTL(+IBEVTP)
- +7 SET IBT(5)=" New Status: "_$EXTRACT($$TEXT^IBARXEU0($PIECE(IBEVTA,"^",4))_" ",1,10)_" - "_$PIECE($GET(^IBE(354.2,+$PIECE(IBEVTA,"^",5),0)),"^")_" Dated "_$$DAT1^IBOUTL(+IBEVTA)
- +8 SET IBT(6)=""
- IF $DATA(IBARCAN)
- SET IBT(6)="Past charges were canceled in AR."
- +9 SET IBT(7)=""
- +10 SET IBT(8)=""
- +11 SET IBT(10)=" by: "_$PIECE($GET(^VA(200,+$PIECE(IBEVTA,"^",7),0)),"^")_"/"_$SELECT($PIECE(IBEVTA,"^",6)=1:"(System)",1:"(Manual)")
- +12 SET Y=$PIECE(IBEVTA,"^",8)
- DO D^DIQ
- SET IBT(11)=" on: "_$PIECE(Y,"@")_" @ "_$PIECE(Y,"@",2)
- +13 SET IBT(12)="Option: "
- IF $DATA(XQY0)
- SET IBT(12)=IBT(12)_$PIECE($GET(XQY0),"^",2)
- +14 IF $DATA(ZTQUEUED)
- IF $PIECE($GET(XQY0),"^",2)=""
- SET IBT(12)=IBT(12)_"Queued Job - "_$GET(ZTDESC)
- +15 DO SEND
- BULLQ QUIT
- +1 ;
- SEND SET XMDUZ="INTEGRATED BILLING PACKAGE"
- SET XMTEXT="IBT("
- +1 KILL XMY
- SET XMN=0
- +2 ;S XMY(DUZ)="" ;don't send to user, is annoying to pharmacy.
- +3 SET IBGRP=$PIECE($GET(^XMB(3.8,+$PIECE($GET(^IBE(350.9,1,0)),"^",13),0)),"^")
- +4 IF IBGRP]""
- SET XMY("G."_IBGRP_"@"_^XMB("NETNAME"))=""
- +5 ;S IBGRP=$P(^IBE(350.9,1,0),"^",9)
- +6 ;F IBI=0:0 S IBI=$O(^XMB(3.8,+IBGRP,1,"B",IBI)) Q:'IBI S XMY(IBI)=""
- +7 DO ^XMD
- +8 KILL X,Y,IBI,IBT,IBGRP,XMDUZ,XMTEXT,XMY,XMSUB
- +9 QUIT
