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

IBACV.m

Go to the documentation of this file.
  1. IBACV ;WOIFO/SS-COMBAT VET UTILITIES ;7-AUG-03
  1. ;;2.0;INTEGRATED BILLING;**234,247,275,339,347** ;21-MAR-94;Build 24
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;To replace CL^SDCO21 with CL^IBACV that wraps out both CL^SDCO21 and $$CVEDT^DGCV
  1. CL(IBDFN,IBSDDT,IBSDOE,IBSDCLY) ;Build Classification Array
  1. ; Input -- DFN Patient file IEN
  1. ; SDDT Date/Time [Optional]
  1. ; SDOE Outpatient Encounter file IEN [Optional]
  1. ; Output -- SDCLY Classification Array
  1. ; Subscripted by Class. Type file (#409.41) IEN
  1. ;
  1. D CL^SDCO21(IBDFN,$G(IBSDDT),$G(IBSDOE),.IBSDCLY)
  1. Q
  1. ;
  1. ;returns CV status as:
  1. ; current_CV_status^end_date^if_ever_had_CV_status
  1. CVEDT(IBDFN,IBDT) ;
  1. N IBRET S IBRET=$$CVEDT^DGCV($G(IBDFN),$G(IBDT))
  1. Q (+$P(IBRET,"^",3))_"^"_(+$P(IBRET,"^",2))_"^"_(+$P(IBRET,"^",1)) ;swop
  1. ;
  1. ;/**
  1. ;Return the classification description of code sets for #.03 in #351.2.
  1. ; Input:
  1. ; X -- Patient class [1-ao|2-ir|3-swa|4-sc|5-mst|6-hnc|7-cv|8-SHAD]
  1. ; IBCASE -- "M" - mixed case (the first letter is uppercase and others-lowercase)
  1. PATTYPE(X,IBCASE) ; */
  1. N IBZ
  1. S IBZ=$S(X=1:"AGENT ORANGE",X=2:"IONIZING RADIATION",X=3:"SOUTHWEST ASIA",X=4:"SERVICE CONNECTED",X=5:"MILITARY SEXUAL TRAUMA",X=6:"HEAD/NECK CANCER",X=7:"COMBAT VETERAN",X=8:"PROJECT 112/SHAD",1:"SPECIAL")
  1. Q:$G(IBCASE)="M" $$LOWER^VALM1(IBZ)
  1. Q IBZ
  1. ;
  1. PATTYAB(X) ; Return External Abbreviation of Special Inpatient Billing Case Patient Type (#351.2,.03)
  1. ; Input: 351.2, .03 internal value
  1. N IBZ S X=$G(X)
  1. S IBZ=$S(X=1:"AO",X=2:"IR",X=3:"SWA",X=4:"SC",X=5:"MST",X=6:"HNC",X=7:"CV",X=8:"SHAD",1:"UNK")
  1. Q IBZ
  1. ;
  1. ;if Combat Vet sends e-mail to mailgroup "IB COMBAT VET RX COPAY"
  1. ;IBDFN-patient IEN, IBDT - date, IBRXPTR - pointer to #52 file to get prescription #
  1. RXALRT(IBDFN,IBDT,IBRXPTR) ;
  1. N IB1
  1. S IB1=$$CVEDT(IBDFN,$G(IBDT))
  1. I +IB1 D EMAIL(IBDFN,$G(IBDT),$P(IB1,"^",2),$G(IBRXPTR))
  1. Q
  1. ;sends e-mail to mail group IB COMBAT VET RX COPAY
  1. EMAIL(DFN,IBEFDT,IBEXPDT,IBRX) ;
  1. N IBTODAY,IBPAT,IBT,IBSSN
  1. N XMSUB,XMY,XMTEXT,XMDUZ
  1. N Y D NOW^%DTC S Y=%\1 X ^DD("DD") S IBTODAY=Y
  1. I +$G(DFN)>0 D
  1. . N VADM,VA,VAERR
  1. . D DEM^VADPT
  1. . S IBPAT=$G(VADM(1))
  1. . S IBSSN=$P($G(VADM(2)),"^",2)
  1. I $G(IBRX) S IBRX=$$FILE^IBRXUTL(IBRX,.01) ;get RX number
  1. S:IBPAT="" IBPAT="Unknown"
  1. S XMSUB="COMBAT VET RX COPAY REVIEW NEEDED"
  1. S XMY("G.IB COMBAT VET RX COPAY")=""
  1. S XMTEXT="IBT(",XMDUZ="INTEGRATED BILLING PACKAGE"
  1. S IBT(1,0)="PATIENT: "_IBPAT
  1. I $G(IBEXPDT)>0 S Y=IBEXPDT X ^DD("DD") S IBT(1,0)=IBT(1,0)_" COMBAT VET until: "_Y
  1. S IBT(2,0)="SSN: "_IBSSN
  1. S IBT(3,0)=""
  1. S IBT(4,0)=$S($G(IBRX)'="":"RX#: "_$G(IBRX),1:"")
  1. S IBT(5,0)="RX RELEASE DATE: "_IBTODAY
  1. S IBT(6,0)=""
  1. S IBT(7,0)="The above patient has a Combat Veteran status. Please review this"
  1. S IBT(8,0)="prescription to determine if the RX Copay charge should be cancelled."
  1. S IBT(9,0)=""
  1. D ^XMD
  1. Q
  1. ;
  1. ;--------------------------------------------------------------------
  1. ;is called from PROC^IBAMTC for each active inpatient
  1. IFCVEXP(IBDFN,IBNJDT,IB405) ;
  1. ;Input:IBDFN1 - patient's ien in PATIENT file
  1. ; IBNJDT - Nightly Job date
  1. ; IB405 - ptr to #405
  1. N IBTSTDT,IBPAT,IBZ,IBEXPIR,IBADM
  1. S IBPAT=$$PT^IBEFUNC(IBDFN)
  1. S (IBZ,IBEXPIR)=0
  1. S IBZ=$$CVEDT^IBACV(IBDFN,IBNJDT)
  1. I $P(IBZ,"^",3)=0 Q ;patient has never been CV
  1. S IBEXPIR=+$P(IBZ,"^",2)\1
  1. I IBEXPIR>IBNJDT Q ;expires in the future
  1. ;get last date when Nightly job checked CV status for inpatients
  1. S IBTSTDT=$$XTMPLST()
  1. ;if ^XTMP is not there then make the last CV check date as TODAY-7
  1. I IBTSTDT=0 S IBTSTDT=$$CHNGDATE^IBAHVE3(IBNJDT,-7) D SETXTMP0(IBTSTDT)
  1. S IBADM=+$G(^DGPM(IB405,0))\1 ;admission/movement date
  1. I IBTSTDT'<IBNJDT Q
  1. ;check for all the days since the last check date thru today
  1. F D Q:(IBTSTDT'<IBNJDT)!(IBTSTDT=IBEXPIR)
  1. . S IBTSTDT=$$CHNGDATE^IBAHVE3(IBTSTDT,+1) ;next date
  1. . ;quit if the date is before the admission
  1. . I IBTSTDT<IBADM Q
  1. . ;send alert if CV expires this day
  1. . I IBEXPIR=IBTSTDT D SETXTPM(IBDFN,IBTSTDT,IBEXPIR,IBADM,IBPAT)
  1. Q
  1. ;
  1. XTMPLST() ;get the last CV check date in ^XTMP
  1. Q +$P($G(^XTMP("IBCVEXPDT",0)),"^",2)
  1. ;
  1. SETXTPM(IBDFN,IBCHKDT,IBEXP,IBADMIS,IBPT) ;save info in ^XTMP
  1. ;Input:IBDFN - patient's ien in PATIENT file
  1. ; IBEXP - CV expiration date
  1. ; IBADMIS - admission/movement date
  1. ; IBPT - patient's info
  1. S ^XTMP("IBCVEXPDT",IBDFN)=IBDFN_"^"_IBCHKDT_"^"_IBEXP_"^"_IBADMIS_"^"_$P(IBPT,"^",1,2)
  1. Q
  1. ;
  1. ;is called from IBAMTC after PROC^IBAMTC and sends e-mail alert
  1. ;with the list of inpatient's with CV expired
  1. CVEXMAIL(IBDT) ;send all e-mails
  1. N Y,IBT,IBZ1,IBZ2,IBC,IBT,IBTOTAL
  1. S IBC=0,IBTOTAL=0
  1. ;loop thru ^XTMP
  1. S IBZ1=0 F S IBZ1=$O(^XTMP("IBCVEXPDT",IBZ1)) Q:+IBZ1=0 D
  1. . D HEADER
  1. . S IBZ2=$G(^XTMP("IBCVEXPDT",IBZ1))
  1. . I IBZ2'="" S IBTOTAL=IBTOTAL+1 D MKEMAIL($P(IBZ2,U,3),$P(IBZ2,U,4),$P(IBZ2,U,5),$P(IBZ2,U,6))
  1. I IBC>0 D
  1. . D FOOTER(IBTOTAL)
  1. . D SEND^IBACVA2
  1. D SETXTMP0(IBDT)
  1. Q
  1. ;
  1. I IBC>0 Q
  1. S XMSUB="INPATIENTS' COMBAT VET STATUS EXPIRED"
  1. N IBX S IBX="",$P(IBX,"=",70)=""
  1. S IBC=IBC+1,IBT(IBC)="The following patients whose records indicate that they had CV status, were"
  1. S IBC=IBC+1,IBT(IBC)="admitted for inpatient care with CV status, and their CV status has expired"
  1. S IBC=IBC+1,IBT(IBC)="during their stays. Please check their CV exp date again before adjusting"
  1. S IBC=IBC+1,IBT(IBC)="their billings accordingly."
  1. S IBC=IBC+1,IBT(IBC)=""
  1. S IBC=IBC+1,IBT(IBC)=$$LRJ("Patient NAME",23)_$$LRJ("SSN",14)_$$LRJ("CV exp. date",20)_$$LRJ("Date of admission",20)
  1. S IBC=IBC+1,IBT(IBC)=IBX
  1. Q
  1. S IBC=IBC+1,IBT(IBC)=""
  1. S IBC=IBC+1,IBT(IBC)="Total: "_IBTOTAL_" patient(s)"
  1. Q
  1. ;
  1. MKEMAIL(IBEXP,IBADM,IBNAME,IBSSN) ;
  1. ;send e-mail alert if CV does expire today
  1. N Y
  1. S Y=IBEXP D DD^%DT S IBEXP=Y
  1. S Y=IBADM D DD^%DT S IBADM=Y
  1. S IBC=IBC+1,IBT(IBC)=$$LRJ($E(IBNAME,1,21),23)_$$LRJ(IBSSN,14)_$$LRJ(IBEXP,20)_$$LRJ(IBADM,20)
  1. Q
  1. ;
  1. SETXTMP0(IBDT) ;set the new "last CV check date" in ^XTMP
  1. N IBPURGDT S IBPURGDT=+$$CHNGDATE^IBAHVE3(IBDT,+7)
  1. K ^XTMP("IBCVEXPDT")
  1. S ^XTMP("IBCVEXPDT",0)=IBPURGDT_"^"_IBDT_"^LAST DATE NIGHTLY JOB CHECKED COMBAT VET EXPIRATION FOR INPATIENTS"
  1. Q
  1. ;
  1. ;---
  1. ;adds spaces on right/left or truncates to make return string IBLEN characters long
  1. ;IBST- original string
  1. ;IBLEN - desired length
  1. ;IBCHR -character (default = SPACE)
  1. ;IBSIDE - on which side to add characters (default = RIGHT)
  1. LRJ(IBST,IBLEN,IBCHR,IBSIDE) ;
  1. N Y S $P(Y,$S($L($G(IBCHR)):IBCHR,1:" "),$S(IBLEN-$L(IBST)<0:1,1:IBLEN-$L(IBST)+1))=""
  1. Q $E($S($G(IBSIDE)="L":Y_IBST,1:IBST_Y),1,IBLEN)
  1. ;---
  1. ;