- IBARXEU ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ; 2-NOV-92
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;
- RXST(DFN,IBDT) ; -- Check rx income exemption status of patient
- ;
- ; input = : dfn = patient file pointer
- ; ibdt = date to check for (optional) default is today
- ;
- ; returns : -1 if no data ^text^reason code^reason text^date of test
- ; 0 if non exempt
- ; 1 if exempt
- ;
- N X,Y,IBX,IBON
- ;
- S IBON=$$ON^IBARXEU0 I IBON<1 Q IBON
- ;
- S IBX=""
- I '$G(IBDT) S IBDT=DT
- I IBDT>DT S IBDT=DT ; no future dates
- ;
- ; -- date before legislations
- I IBDT<$$STDATE S IBX="0^NON-EXEMPT^^Date is Prior to Legislation^" G RXSTQ ; nobody exempt prior to legislation
- ;
- ; -- if no data on patient quit
- S X=$G(^IBA(354,DFN,0)) I X=""!('$D(^IBA(354.1,"AP",DFN))) S IBX="-1^UNKNOWN^^Medication Copayment Exemption status never determined" G RXSTQ ; no data return -1
- ;
- ; -- use current status if ibdt not less than current test and
- ; not greater than current test date +365
- I IBDT'<$P(X,"^",3),IBDT'>$$PLUS^IBARXEU0($P(X,U,3)) S IBX=$$IBX^IBARXEU0(DFN,IBDT) G RXSTQ
- ;
- ; -- if ibdt not less than current date but greater than
- ; current test +365 is into future
- I IBDT'<$P(X,"^",3),IBDT>$$PLUS^IBARXEU0($P(X,U,3)) D
- .S Y=$$LST^IBARXEU0(DFN,IBDT)
- .S IBX=+$P(X,"^",4)_"^"_"Previously "_$$TEXT^IBARXEU0($P(X,"^",4))_"^"_$$ACODE^IBARXEU0(Y)_"^"_"Requires new exemption. Previously "_$$REASON^IBARXEU0(Y)_"^"_+Y
- ;
- ; -- if ibdt less than current date need old exemption data
- I IBDT<$P(X,"^",3) D G RXSTQ
- .;
- .; -- find status of prior test
- .S Y=$$LST^IBARXEU0(DFN,IBDT)
- .;
- .; -- no previous data
- .I Y="" D Q
- ..S IBX="-1^UNKNOWN^^No data for date requested."
- ..Q
- .;
- .; --if old exemption is current for copay date
- .I IBDT'>$$PLUS^IBARXEU0(+Y) D Q
- ..S X=$G(^IBE(354.2,+$P(Y,"^",5),0)) ; exemption reason node
- ..S IBX=+$P(X,"^",4)_"^"_$$TEXT^IBARXEU0($P(X,"^",4))_"^"_$$ACODE^IBARXEU0(Y)_"^"_$$REASON^IBARXEU0(Y)_"^"_+Y
- ..Q
- .;
- .; -- if ibdt is greater than old exemption + 365
- .; report previous
- .I IBDT>$$PLUS^IBARXEU0(+Y) D Q
- ..S X=$G(^IBE(354.2,+$P(Y,"^",5),0)) ;exemption reason node
- ..S IBX=+$P(X,"^",4)_"^"_"Previously "_$$TEXT^IBARXEU0($P(X,"^",4))_"^"_$$ACODE^IBARXEU0(Y)_"^"_"Requires new exemption. Previously "_$$REASON^IBARXEU0(Y)_"^"_+Y
- ..Q
- .Q
- ;
- RXSTQ Q IBX
- ;
- DISP(DFN,IBDT,NO,NULL) ; -- formats text to display
- ; -- input = dfn
- ; ibdt = date to check for
- ; no = number of lines to print (1, 2, or 3)
- ; null = if zero print unknown, if non-zero quit
- ;
- I '$G(IBDT) S IBDT=DT
- I '$D(NULL) S NULL=1
- I IBDT>DT S IBDT=DT ; no future dates
- I '$G(NO) S NO=3
- S X=$$RXST(DFN,IBDT)
- S IBON=$$ON^IBARXEU0 I IBON<1 S X=IBON
- I X<0&(NULL) G DISPQ
- W !,"Medication Copayment Exemption Status: ",$P(X,"^",2) G:NO<2 DISPQ
- W !,$P(X,"^",4) G:NO<3 DISPQ
- I $P(X,"^",5) W !,"Test date: " S Y=$P(X,"^",5) D DT^DIQ
- DISPQ Q
- ;
- STDATE() ; -- legislative start date for income exemption
- Q 2921030
- ;
- ;
- ACTIVE(IBZ) ; -- SCREEN for active field of billing exemptions file
- ; only one entry per effective date can be active
- ;
- N IBX,IBY,T
- S T=0
- S IBZ=$S(IBZ=1:IBZ,$E(IBZ)="A":1,1:0)
- I 'IBZ S T=1 G ACTIVEQ
- S IBX=$G(^IBA(354.1,DA,0))
- S IBY=$O(^IBA(354.1,"AIVDT",+$P(IBX,"^",3),+$P(IBX,"^",2),-$P(IBX,"^"),0))
- I 'IBY!(IBY=DA) S T=1
- W:$D(IBTALK) !!,"Another entry is already Active, You must inactivate it first",!!
- ACTIVEQ Q T
- IBARXEU ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ; 2-NOV-92
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 ;
- RXST(DFN,IBDT) ; -- Check rx income exemption status of patient
- +1 ;
- +2 ; input = : dfn = patient file pointer
- +3 ; ibdt = date to check for (optional) default is today
- +4 ;
- +5 ; returns : -1 if no data ^text^reason code^reason text^date of test
- +6 ; 0 if non exempt
- +7 ; 1 if exempt
- +8 ;
- +9 NEW X,Y,IBX,IBON
- +10 ;
- +11 SET IBON=$$ON^IBARXEU0
- IF IBON<1
- QUIT IBON
- +12 ;
- +13 SET IBX=""
- +14 IF '$GET(IBDT)
- SET IBDT=DT
- +15 ; no future dates
- IF IBDT>DT
- SET IBDT=DT
- +16 ;
- +17 ; -- date before legislations
- +18 ; nobody exempt prior to legislation
- IF IBDT<$$STDATE
- SET IBX="0^NON-EXEMPT^^Date is Prior to Legislation^"
- GOTO RXSTQ
- +19 ;
- +20 ; -- if no data on patient quit
- +21 ; no data return -1
- SET X=$GET(^IBA(354,DFN,0))
- IF X=""!('$DATA(^IBA(354.1,"AP",DFN)))
- SET IBX="-1^UNKNOWN^^Medication Copayment Exemption status never determined"
- GOTO RXSTQ
- +22 ;
- +23 ; -- use current status if ibdt not less than current test and
- +24 ; not greater than current test date +365
- +25 IF IBDT'<$PIECE(X,"^",3)
- IF IBDT'>$$PLUS^IBARXEU0($PIECE(X,U,3))
- SET IBX=$$IBX^IBARXEU0(DFN,IBDT)
- GOTO RXSTQ
- +26 ;
- +27 ; -- if ibdt not less than current date but greater than
- +28 ; current test +365 is into future
- +29 IF IBDT'<$PIECE(X,"^",3)
- IF IBDT>$$PLUS^IBARXEU0($PIECE(X,U,3))
- Begin DoDot:1
- +30 SET Y=$$LST^IBARXEU0(DFN,IBDT)
- +31 SET IBX=+$PIECE(X,"^",4)_"^"_"Previously "_$$TEXT^IBARXEU0($PIECE(X,"^",4))_"^"_$$ACODE^IBARXEU0(Y)_"^"_"Requires new exemption. Previously "_$$REASON^IBARXEU0(Y)_"^"_+Y
- End DoDot:1
- +32 ;
- +33 ; -- if ibdt less than current date need old exemption data
- +34 IF IBDT<$PIECE(X,"^",3)
- Begin DoDot:1
- +35 ;
- +36 ; -- find status of prior test
- +37 SET Y=$$LST^IBARXEU0(DFN,IBDT)
- +38 ;
- +39 ; -- no previous data
- +40 IF Y=""
- Begin DoDot:2
- +41 SET IBX="-1^UNKNOWN^^No data for date requested."
- +42 QUIT
- End DoDot:2
- QUIT
- +43 ;
- +44 ; --if old exemption is current for copay date
- +45 IF IBDT'>$$PLUS^IBARXEU0(+Y)
- Begin DoDot:2
- +46 ; exemption reason node
- SET X=$GET(^IBE(354.2,+$PIECE(Y,"^",5),0))
- +47 SET IBX=+$PIECE(X,"^",4)_"^"_$$TEXT^IBARXEU0($PIECE(X,"^",4))_"^"_$$ACODE^IBARXEU0(Y)_"^"_$$REASON^IBARXEU0(Y)_"^"_+Y
- +48 QUIT
- End DoDot:2
- QUIT
- +49 ;
- +50 ; -- if ibdt is greater than old exemption + 365
- +51 ; report previous
- +52 IF IBDT>$$PLUS^IBARXEU0(+Y)
- Begin DoDot:2
- +53 ;exemption reason node
- SET X=$GET(^IBE(354.2,+$PIECE(Y,"^",5),0))
- +54 SET IBX=+$PIECE(X,"^",4)_"^"_"Previously "_$$TEXT^IBARXEU0($PIECE(X,"^",4))_"^"_$$ACODE^IBARXEU0(Y)_"^"_"Requires new exemption. Previously "_$$REASON^IBARXEU0(Y)_"^"_+Y
- +55 QUIT
- End DoDot:2
- QUIT
- +56 QUIT
- End DoDot:1
- GOTO RXSTQ
- +57 ;
- RXSTQ QUIT IBX
- +1 ;
- DISP(DFN,IBDT,NO,NULL) ; -- formats text to display
- +1 ; -- input = dfn
- +2 ; ibdt = date to check for
- +3 ; no = number of lines to print (1, 2, or 3)
- +4 ; null = if zero print unknown, if non-zero quit
- +5 ;
- +6 IF '$GET(IBDT)
- SET IBDT=DT
- +7 IF '$DATA(NULL)
- SET NULL=1
- +8 ; no future dates
- IF IBDT>DT
- SET IBDT=DT
- +9 IF '$GET(NO)
- SET NO=3
- +10 SET X=$$RXST(DFN,IBDT)
- +11 SET IBON=$$ON^IBARXEU0
- IF IBON<1
- SET X=IBON
- +12 IF X<0&(NULL)
- GOTO DISPQ
- +13 WRITE !,"Medication Copayment Exemption Status: ",$PIECE(X,"^",2)
- IF NO<2
- GOTO DISPQ
- +14 WRITE !,$PIECE(X,"^",4)
- IF NO<3
- GOTO DISPQ
- +15 IF $PIECE(X,"^",5)
- WRITE !,"Test date: "
- SET Y=$PIECE(X,"^",5)
- DO DT^DIQ
- DISPQ QUIT
- +1 ;
- STDATE() ; -- legislative start date for income exemption
- +1 QUIT 2921030
- +2 ;
- +3 ;
- ACTIVE(IBZ) ; -- SCREEN for active field of billing exemptions file
- +1 ; only one entry per effective date can be active
- +2 ;
- +3 NEW IBX,IBY,T
- +4 SET T=0
- +5 SET IBZ=$SELECT(IBZ=1:IBZ,$EXTRACT(IBZ)="A":1,1:0)
- +6 IF 'IBZ
- SET T=1
- GOTO ACTIVEQ
- +7 SET IBX=$GET(^IBA(354.1,DA,0))
- +8 SET IBY=$ORDER(^IBA(354.1,"AIVDT",+$PIECE(IBX,"^",3),+$PIECE(IBX,"^",2),-$PIECE(IBX,"^"),0))
- +9 IF 'IBY!(IBY=DA)
- SET T=1
- +10 IF $DATA(IBTALK)
- WRITE !!,"Another entry is already Active, You must inactivate it first",!!
- ACTIVEQ QUIT T
