IBARXEPS ;ALB/RM/PHH,EG - RX COPAY EXEMPTION UPDATE STATUS ; 12/13/2005
;;2.0;INTEGRATED BILLING;**321**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; This routine was copied/modified from IBARXEPV.
;
Q
POST ; Entry point from TaskMan
I '$D(DT) D
.N %,%H,%I,X,DT
.D NOW^%DTC
.S DT=X
N NAMESPC
S NAMESPC=$$NAMESPC()
D UPDT($E(DT,1,3)_"0101",DT,1)
K ^XTMP(NAMESPC,"RUNNING")
Q
START ;Entry Point from post-install
N QTIME,X,NAMESPC
S NAMESPC=$$NAMESPC()
Q:$$RUNCHK(NAMESPC) ; Quit if already running or has run to completion
K ^XTMP(NAMESPC)
S X=$$QTIME(.QTIME)
S ^XTMP(NAMESPC,"USER")=$S($G(DUZ)'="":DUZ,1:"UNKNOWN")
S:'$$QUEUE(QTIME) ^XTMP(NAMESPC,"RUNNING")=""
Q
NAMESPC() ; API returns the name space for this patch
Q "IBARXEPS"
RUNCHK(NAMESPC) ; Check to see if clean up is already running
Q:NAMESPC="" 1 ; Name Space must be defined
Q:$D(^XTMP(NAMESPC,"RUNNING")) 1
Q 0
QTIME(WHEN) ; Get the run time for queuing
N %,%H,%I,X
D NOW^%DTC
S WHEN=$P(%,".")_"."_$E($P(%,".",2),1,4)
Q 0
QUEUE(ZTDTH) ; Queue the process
N NAMESPC,QUEERR,ZTDESC,ZTRTN,ZTSK
S NAMESPC=$$NAMESPC
S QUEERR=0
S ZTRTN="POST^IBARXEPS"
S ZTDESC=NAMESPC_" - RX COPAY EXEMPTION UPDATE STATUS"
S ZTIO=""
D ^%ZTLOAD
K ^XTMP(NAMESPC,"ZTSK")
I '$D(ZTSK) S ^XTMP(NAMESPC,"ZTSK")="Unable to queue post-install process.",QUEERR=1
I $D(ZTSK) D
. S ^XTMP(NAMESPC,"ZTSK")="Post-install queued. Task ID: "_$G(ZTSK)
. D MES^XPDUTL(" This request queued as Task # "_ZTSK)
. D MES^XPDUTL("")
. Q
Q QUEERR
;
UPDT(IBBDT,IBEDT,IBUP) ;
; IBBDT - Beginning Date for the process
; IBEDT - Ending Date for the process
; IBUP - Update mode (1 - Update, 0 - Report only)
;
; All three input parameters are required
I 'IBBDT!('IBEDT)!(IBEDT<IBBDT) Q
;
; Entry point to start comparison
N IBJOB,IBWHER,%
S (IBPCNT,IBPAG)=0,IBOK=1 D NOW^%DTC S Y=% D D^DIQ
S IBPDAT=$P(Y,"@")_" "_$E($P(Y,"@",2),1,5)
K ^TMP($J,"IBUNVER")
;
; Look through EFFECTIVE DATE x-ref in BILLING EXEMPTIONS File #354.1
S IBDT=IBBDT-.00001
F S IBDT=$O(^IBA(354.1,"B",IBDT)) Q:'IBDT!(IBDT>(IBEDT+.9)) D
.S IBDA=0 F S IBDA=$O(^IBA(354.1,"B",IBDT,IBDA)) Q:'IBDA D
..D CHK I 'IBOK D UP:IBUP,SET
D REPORT
;
K ^TMP($J,"IBUNVER")
K DFN,DIR,DIRUT,DIC,DIE,DA,DR,X,Y
K IBBDT,IBDA,IBDATA,IBDEPEN,IBDFN,IBDT,IBEDT,IBER,IBERR,IBEXREA,IBEXREAN,IBEXREAO,IBJ,IBMESS,IBNAM,IBOK,IBP,IBPAG,IBPCNT,IBPDAT,IBQUIT,IBUP
Q
;
CHK ; Check if current status = computed status
S IBOK=1,IBMESS="Nothing Updated",IBERR=""
S X=$G(^IBA(354.1,+IBDA,0)) G CHKQ:'$P(X,"^",10) ;not active skip
S DFN=$P(X,"^",2)
S Y=$G(^IBA(354,DFN,0)) I +X<$P(Y,"^",3) G CHKQ ;not current exemption
;
N DGMT,CONV,CLN S (CLN,CONV)=0,DGMT=$$LST^DGMTU(DFN,+X,1)
I $P(DGMT,U,5)=2 D G:CONV CHKQ ; skip Edb conv. tests
.; Loop through the MT comments, Check for EDB converted test
.; No comments to check
.Q:'$D(^DGMT(408.31,+DGMT,"C",1,0))
.F S CLN=$O(^DGMT(408.31,+DGMT,"C",CLN)) Q:'CLN!(CONV) D
..I ^DGMT(408.31,+DGMT,"C",CLN,0)["Z06 MT via Edb" S CONV=1
;
S IBPCNT=IBPCNT+1
I '+Y S IBOK=0,IBERR=4
S IBEXREAO=$P(X,"^",5)_"^"_+X ;current exemption
I $P($G(^IBE(354.2,+IBEXREAO,0)),"^",5)=2010 G CHKQ ; hardships don't report
I +X>$P(Y,"^",3) S IBOK=0,IBERR=1 ;most current exemption not in 354
I $P(X,"^",5)'=$P(Y,"^",5) S IBOK=0,IBERR=2 ;Current exemption not in 354
I $P(X,"^",4)'=$P(Y,"^",4) S IBOK=0,IBERR=5 ;current status in exemption not in 354
S IBEXREAN=$$STATUS^IBARXEU1(DFN,DT)
I +IBEXREAO'=+IBEXREAN S IBOK=0,IBERR=3
CHKQ Q
;
UP ; -- update current exemption status
Q:IBOK
S IBJOB=15,IBWHER=16
I IBERR=4 D G UPQ
.S DIE="^IBA(354,",DA=DFN,DR=".01////"_DFN D ^DIE
.K DIE,DA,DR,DIC
.S IBMESS="Name Corrected"
UP1 N IBOLDAUT S IBOLDAUT=""
;
; -- if currently not auto exempt make sure not more recent auto exempt
I $L($P($G(^IBE(354.2,+IBEXREAN,0)),"^",5))>2 D OLDAUT^IBARXEX1(IBEXREAN)
S IBFORCE=$P(IBEXREAN,"^",2)
D MOSTR^IBARXEU5($P(IBEXREAN,"^",2),+IBEXREAN)
D ADDEX^IBAUTL6(+IBEXREAN,$P(IBEXREAN,"^",2),1,1,IBOLDAUT)
S IBMESS="Updated"
UPQ K IBFORCE Q
;
SET ; Set ^tmp node if not okay
Q:IBOK
S IBP=$$PT^IBEFUNC(DFN)
S IBDFN=DFN
I $D(^TMP($J,"IBUNVER",$P(IBP,"^"),DFN)) S IBDFN=DFN_"-"_IBPCNT
S ^TMP($J,"IBUNVER",$P(IBP,"^"),IBDFN)=IBEXREAO_"^"_IBEXREAN_"^"_IBERR_"^"_IBMESS_"^"_IBP
Q
;
REPORT ; Send MailMan recap report of updated records
N IBMGRP,XMDUZ,XMTEXT,XMY,XMSUB,LNCNT,IBPDAT,IBDCNT,MSG,TXT,EXRSN,XMDUZ
S IBMGRP=$$GET1^DIQ(350.9,1,.13)
Q:IBMGRP=""
S IBMGRP=$O(^XMB(3.8,"B",IBMGRP,""))
Q:'IBMGRP
D XMY^DGMTUTL(IBMGRP,0,1)
S XMDUZ="IB PACKAGE",XMTEXT="MSG(",LNCNT=1,IBDCNT=0
S XMY(DUZ)="",XMSUB="IB RX COPAY EXEMPT UPDATE"
D NOW^%DTC S Y=% D D^DIQ S IBPDAT=$P(Y,"@")_" "_$E($P(Y,"@",2),1,5)
S MSG(LNCNT)=" Medication Copayment Exemption Problem Report "_IBPDAT
S LNCNT=LNCNT+1,MSG(LNCNT)=" "
S TXT="Patient PT. ID Error Current/Calc Exemption"
S LNCNT=LNCNT+1,MSG(LNCNT)=TXT
S LNCNT=LNCNT+1,MSG(LNCNT)=$TR($J(" ",78)," ","-")
D EXRSN
S IBNAM="" F S IBNAM=$O(^TMP($J,"IBUNVER",IBNAM)) Q:IBNAM="" D
.S IBDFN="" F S IBDFN=$O(^TMP($J,"IBUNVER",IBNAM,IBDFN)) Q:IBDFN="" D
..S IBER=^(IBDFN) D MSGLN(IBNAM,IBER)
;
I $D(^TMP($J,"IBUNVER")) D
.S LNCNT=LNCNT+1,MSG(LNCNT)=" "
.S LNCNT=LNCNT+1,MSG(LNCNT)="There were "_IBDCNT_" discrepancies found in "_IBPCNT_" exemptions checked."
I '$D(^TMP($J,"IBUNVER")) S LNCNT=LNCNT+1,MSG(LNCNT)=" No discrepancies found in "_IBPCNT_" exemptions checked."
D ^XMD
REPORTQ Q
;
MSGLN(IBNAM,IBER) ; Create the body of the report
N IBSSN,IBCURX,IBCALX,RECORD
S IBNAM=$E(IBNAM,1,20),IBDCNT=IBDCNT+1
S IBSSN=$P(IBER,U,8)
S X=$P(IBER,U,5),X=$E($S(X=3:"Incorr Exmpt",X=1!(X=2)!(X=5):"Not Curr Stat",X=4:"Name Missing",1:"Hmmmm"),1,13)
S IBCURX=EXRSN($P(IBER,U))
S IBCALX=EXRSN($P(IBER,U,3))
S RECORD=$$LJ^XLFSTR(IBNAM,22," ")_IBSSN_" "_$$LJ^XLFSTR(X,15," ")_IBCURX_"/"_IBCALX
S LNCNT=LNCNT+1,MSG(LNCNT)=RECORD
Q
;
EXRSN ; Exempt Reason Array for MailMan Message
N IBIEN S IBIEN=0
F S IBIEN=$O(^IBE(354.2,IBIEN)) Q:'IBIEN S EXRSN(IBIEN)=$E($P(^IBE(354.2,IBIEN,0),U),1,15)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEPS 6328 printed Apr 09, 2024@21:25:27 Page 2
IBARXEPS ;ALB/RM/PHH,EG - RX COPAY EXEMPTION UPDATE STATUS ; 12/13/2005
+1 ;;2.0;INTEGRATED BILLING;**321**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; This routine was copied/modified from IBARXEPV.
+5 ;
+6 QUIT
POST ; Entry point from TaskMan
+1 IF '$DATA(DT)
Begin DoDot:1
+2 NEW %,%H,%I,X,DT
+3 DO NOW^%DTC
+4 SET DT=X
End DoDot:1
+5 NEW NAMESPC
+6 SET NAMESPC=$$NAMESPC()
+7 DO UPDT($EXTRACT(DT,1,3)_"0101",DT,1)
+8 KILL ^XTMP(NAMESPC,"RUNNING")
+9 QUIT
START ;Entry Point from post-install
+1 NEW QTIME,X,NAMESPC
+2 SET NAMESPC=$$NAMESPC()
+3 ; Quit if already running or has run to completion
if $$RUNCHK(NAMESPC)
QUIT
+4 KILL ^XTMP(NAMESPC)
+5 SET X=$$QTIME(.QTIME)
+6 SET ^XTMP(NAMESPC,"USER")=$SELECT($GET(DUZ)'="":DUZ,1:"UNKNOWN")
+7 if '$$QUEUE(QTIME)
SET ^XTMP(NAMESPC,"RUNNING")=""
+8 QUIT
NAMESPC() ; API returns the name space for this patch
+1 QUIT "IBARXEPS"
RUNCHK(NAMESPC) ; Check to see if clean up is already running
+1 ; Name Space must be defined
if NAMESPC=""
QUIT 1
+2 if $DATA(^XTMP(NAMESPC,"RUNNING"))
QUIT 1
+3 QUIT 0
QTIME(WHEN) ; Get the run time for queuing
+1 NEW %,%H,%I,X
+2 DO NOW^%DTC
+3 SET WHEN=$PIECE(%,".")_"."_$EXTRACT($PIECE(%,".",2),1,4)
+4 QUIT 0
QUEUE(ZTDTH) ; Queue the process
+1 NEW NAMESPC,QUEERR,ZTDESC,ZTRTN,ZTSK
+2 SET NAMESPC=$$NAMESPC
+3 SET QUEERR=0
+4 SET ZTRTN="POST^IBARXEPS"
+5 SET ZTDESC=NAMESPC_" - RX COPAY EXEMPTION UPDATE STATUS"
+6 SET ZTIO=""
+7 DO ^%ZTLOAD
+8 KILL ^XTMP(NAMESPC,"ZTSK")
+9 IF '$DATA(ZTSK)
SET ^XTMP(NAMESPC,"ZTSK")="Unable to queue post-install process."
SET QUEERR=1
+10 IF $DATA(ZTSK)
Begin DoDot:1
+11 SET ^XTMP(NAMESPC,"ZTSK")="Post-install queued. Task ID: "_$GET(ZTSK)
+12 DO MES^XPDUTL(" This request queued as Task # "_ZTSK)
+13 DO MES^XPDUTL("")
+14 QUIT
End DoDot:1
+15 QUIT QUEERR
+16 ;
UPDT(IBBDT,IBEDT,IBUP) ;
+1 ; IBBDT - Beginning Date for the process
+2 ; IBEDT - Ending Date for the process
+3 ; IBUP - Update mode (1 - Update, 0 - Report only)
+4 ;
+5 ; All three input parameters are required
+6 IF 'IBBDT!('IBEDT)!(IBEDT<IBBDT)
QUIT
+7 ;
+8 ; Entry point to start comparison
+9 NEW IBJOB,IBWHER,%
+10 SET (IBPCNT,IBPAG)=0
SET IBOK=1
DO NOW^%DTC
SET Y=%
DO D^DIQ
+11 SET IBPDAT=$PIECE(Y,"@")_" "_$EXTRACT($PIECE(Y,"@",2),1,5)
+12 KILL ^TMP($JOB,"IBUNVER")
+13 ;
+14 ; Look through EFFECTIVE DATE x-ref in BILLING EXEMPTIONS File #354.1
+15 SET IBDT=IBBDT-.00001
+16 FOR
SET IBDT=$ORDER(^IBA(354.1,"B",IBDT))
if 'IBDT!(IBDT>(IBEDT+.9))
QUIT
Begin DoDot:1
+17 SET IBDA=0
FOR
SET IBDA=$ORDER(^IBA(354.1,"B",IBDT,IBDA))
if 'IBDA
QUIT
Begin DoDot:2
+18 DO CHK
IF 'IBOK
if IBUP
DO UP
DO SET
End DoDot:2
End DoDot:1
+19 DO REPORT
+20 ;
+21 KILL ^TMP($JOB,"IBUNVER")
+22 KILL DFN,DIR,DIRUT,DIC,DIE,DA,DR,X,Y
+23 KILL IBBDT,IBDA,IBDATA,IBDEPEN,IBDFN,IBDT,IBEDT,IBER,IBERR,IBEXREA,IBEXREAN,IBEXREAO,IBJ,IBMESS,IBNAM,IBOK,IBP,IBPAG,IBPCNT,IBPDAT,IBQUIT,IBUP
+24 QUIT
+25 ;
CHK ; Check if current status = computed status
+1 SET IBOK=1
SET IBMESS="Nothing Updated"
SET IBERR=""
+2 ;not active skip
SET X=$GET(^IBA(354.1,+IBDA,0))
if '$PIECE(X,"^",10)
GOTO CHKQ
+3 SET DFN=$PIECE(X,"^",2)
+4 ;not current exemption
SET Y=$GET(^IBA(354,DFN,0))
IF +X<$PIECE(Y,"^",3)
GOTO CHKQ
+5 ;
+6 NEW DGMT,CONV,CLN
SET (CLN,CONV)=0
SET DGMT=$$LST^DGMTU(DFN,+X,1)
+7 ; skip Edb conv. tests
IF $PIECE(DGMT,U,5)=2
Begin DoDot:1
+8 ; Loop through the MT comments, Check for EDB converted test
+9 ; No comments to check
+10 if '$DATA(^DGMT(408.31,+DGMT,"C",1,0))
QUIT
+11 FOR
SET CLN=$ORDER(^DGMT(408.31,+DGMT,"C",CLN))
if 'CLN!(CONV)
QUIT
Begin DoDot:2
+12 IF ^DGMT(408.31,+DGMT,"C",CLN,0)["Z06 MT via Edb"
SET CONV=1
End DoDot:2
End DoDot:1
if CONV
GOTO CHKQ
+13 ;
+14 SET IBPCNT=IBPCNT+1
+15 IF '+Y
SET IBOK=0
SET IBERR=4
+16 ;current exemption
SET IBEXREAO=$PIECE(X,"^",5)_"^"_+X
+17 ; hardships don't report
IF $PIECE($GET(^IBE(354.2,+IBEXREAO,0)),"^",5)=2010
GOTO CHKQ
+18 ;most current exemption not in 354
IF +X>$PIECE(Y,"^",3)
SET IBOK=0
SET IBERR=1
+19 ;Current exemption not in 354
IF $PIECE(X,"^",5)'=$PIECE(Y,"^",5)
SET IBOK=0
SET IBERR=2
+20 ;current status in exemption not in 354
IF $PIECE(X,"^",4)'=$PIECE(Y,"^",4)
SET IBOK=0
SET IBERR=5
+21 SET IBEXREAN=$$STATUS^IBARXEU1(DFN,DT)
+22 IF +IBEXREAO'=+IBEXREAN
SET IBOK=0
SET IBERR=3
CHKQ QUIT
+1 ;
UP ; -- update current exemption status
+1 if IBOK
QUIT
+2 SET IBJOB=15
SET IBWHER=16
+3 IF IBERR=4
Begin DoDot:1
+4 SET DIE="^IBA(354,"
SET DA=DFN
SET DR=".01////"_DFN
DO ^DIE
+5 KILL DIE,DA,DR,DIC
+6 SET IBMESS="Name Corrected"
End DoDot:1
GOTO UPQ
UP1 NEW IBOLDAUT
SET IBOLDAUT=""
+1 ;
+2 ; -- if currently not auto exempt make sure not more recent auto exempt
+3 IF $LENGTH($PIECE($GET(^IBE(354.2,+IBEXREAN,0)),"^",5))>2
DO OLDAUT^IBARXEX1(IBEXREAN)
+4 SET IBFORCE=$PIECE(IBEXREAN,"^",2)
+5 DO MOSTR^IBARXEU5($PIECE(IBEXREAN,"^",2),+IBEXREAN)
+6 DO ADDEX^IBAUTL6(+IBEXREAN,$PIECE(IBEXREAN,"^",2),1,1,IBOLDAUT)
+7 SET IBMESS="Updated"
UPQ KILL IBFORCE
QUIT
+1 ;
SET ; Set ^tmp node if not okay
+1 if IBOK
QUIT
+2 SET IBP=$$PT^IBEFUNC(DFN)
+3 SET IBDFN=DFN
+4 IF $DATA(^TMP($JOB,"IBUNVER",$PIECE(IBP,"^"),DFN))
SET IBDFN=DFN_"-"_IBPCNT
+5 SET ^TMP($JOB,"IBUNVER",$PIECE(IBP,"^"),IBDFN)=IBEXREAO_"^"_IBEXREAN_"^"_IBERR_"^"_IBMESS_"^"_IBP
+6 QUIT
+7 ;
REPORT ; Send MailMan recap report of updated records
+1 NEW IBMGRP,XMDUZ,XMTEXT,XMY,XMSUB,LNCNT,IBPDAT,IBDCNT,MSG,TXT,EXRSN,XMDUZ
+2 SET IBMGRP=$$GET1^DIQ(350.9,1,.13)
+3 if IBMGRP=""
QUIT
+4 SET IBMGRP=$ORDER(^XMB(3.8,"B",IBMGRP,""))
+5 if 'IBMGRP
QUIT
+6 DO XMY^DGMTUTL(IBMGRP,0,1)
+7 SET XMDUZ="IB PACKAGE"
SET XMTEXT="MSG("
SET LNCNT=1
SET IBDCNT=0
+8 SET XMY(DUZ)=""
SET XMSUB="IB RX COPAY EXEMPT UPDATE"
+9 DO NOW^%DTC
SET Y=%
DO D^DIQ
SET IBPDAT=$PIECE(Y,"@")_" "_$EXTRACT($PIECE(Y,"@",2),1,5)
+10 SET MSG(LNCNT)=" Medication Copayment Exemption Problem Report "_IBPDAT
+11 SET LNCNT=LNCNT+1
SET MSG(LNCNT)=" "
+12 SET TXT="Patient PT. ID Error Current/Calc Exemption"
+13 SET LNCNT=LNCNT+1
SET MSG(LNCNT)=TXT
+14 SET LNCNT=LNCNT+1
SET MSG(LNCNT)=$TRANSLATE($JUSTIFY(" ",78)," ","-")
+15 DO EXRSN
+16 SET IBNAM=""
FOR
SET IBNAM=$ORDER(^TMP($JOB,"IBUNVER",IBNAM))
if IBNAM=""
QUIT
Begin DoDot:1
+17 SET IBDFN=""
FOR
SET IBDFN=$ORDER(^TMP($JOB,"IBUNVER",IBNAM,IBDFN))
if IBDFN=""
QUIT
Begin DoDot:2
+18 SET IBER=^(IBDFN)
DO MSGLN(IBNAM,IBER)
End DoDot:2
End DoDot:1
+19 ;
+20 IF $DATA(^TMP($JOB,"IBUNVER"))
Begin DoDot:1
+21 SET LNCNT=LNCNT+1
SET MSG(LNCNT)=" "
+22 SET LNCNT=LNCNT+1
SET MSG(LNCNT)="There were "_IBDCNT_" discrepancies found in "_IBPCNT_" exemptions checked."
End DoDot:1
+23 IF '$DATA(^TMP($JOB,"IBUNVER"))
SET LNCNT=LNCNT+1
SET MSG(LNCNT)=" No discrepancies found in "_IBPCNT_" exemptions checked."
+24 DO ^XMD
REPORTQ QUIT
+1 ;
MSGLN(IBNAM,IBER) ; Create the body of the report
+1 NEW IBSSN,IBCURX,IBCALX,RECORD
+2 SET IBNAM=$EXTRACT(IBNAM,1,20)
SET IBDCNT=IBDCNT+1
+3 SET IBSSN=$PIECE(IBER,U,8)
+4 SET X=$PIECE(IBER,U,5)
SET X=$EXTRACT($SELECT(X=3:"Incorr Exmpt",X=1!(X=2)!(X=5):"Not Curr Stat",X=4:"Name Missing",1:"Hmmmm"),1,13)
+5 SET IBCURX=EXRSN($PIECE(IBER,U))
+6 SET IBCALX=EXRSN($PIECE(IBER,U,3))
+7 SET RECORD=$$LJ^XLFSTR(IBNAM,22," ")_IBSSN_" "_$$LJ^XLFSTR(X,15," ")_IBCURX_"/"_IBCALX
+8 SET LNCNT=LNCNT+1
SET MSG(LNCNT)=RECORD
+9 QUIT
+10 ;
EXRSN ; Exempt Reason Array for MailMan Message
+1 NEW IBIEN
SET IBIEN=0
+2 FOR
SET IBIEN=$ORDER(^IBE(354.2,IBIEN))
if 'IBIEN
QUIT
SET EXRSN(IBIEN)=$EXTRACT($PIECE(^IBE(354.2,IBIEN,0),U),1,15)
+3 QUIT
+4 ;
