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