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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEB 2495 printed Apr 09, 2024@21:19:36 Page 2
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
