Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBARXEPS

IBARXEPS.m

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