IBUCVM ;LL/ELZ-LONG TERM CARE CLOCK MAINTANCE ; 06-DEC-19
;;2.0;INTEGRATED BILLING;**663,671,669,675,745**;21-MAR-94;Build 8
;; Per VHA Directive 6402, this routine should not be modified
;
; This routine is used to perform the Urgent Care Visit Tracking
; database Maintenance.
;
Q
;
ENTER ; menu option main entry point
;
N DIC,X,Y,DFN,DTOUT,DUOUT,DIRUT,DIROUT,%,DIR,IBYR,IBLCT,IBAE,IBQUIT
;
S IBQUIT=0 ;Don't quit.
;
; select a patient (screen out patients with no LTC clock and are
; not LTC patients.
LOOP K DIC,X,Y,DFN,IBLTCX,VADP,IBLCT
;
; Clear temp global in case of stoppage during work
K ^TMP($J,"IBUCVM")
;
;Ask for the patient
N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
S DIC="^DPT(",DIC(0)="AEMNQ" W ! D ^DIC G:Y<1 EX
S DFN=+Y D DEM^VADPT
;
S IBYR=$$ASKDT("Enter Year")
G:IBYR=-1 LOOP
;
MLOOP ; Entry/Loop tag to allow user to stay with the defined maintenance utility.
;
S IBLCT=$$PRTVSTS(DFN,IBYR)
;
;Ask user to Add or Edit Visit
W !! ; Space prompt.
S IBAE=$$GETMAINT
I IBAE=-1 G LOOP
;
I IBAE="A" D ADDVST(DFN)
I IBAE="E" D EDITVST(IBLCT)
;
D PAUSE(1)
;
I IBQUIT=1 G LOOP
; Clear temp global after work on the veteran is done.
K ^TMP($J,"IBUCVM")
G MLOOP
;
EX ;
D KVAR^VADPT
;
Q
;
ASKDT(IBPRMT) ;Date input
N DIR,Y,X,DIROUT,DIRUT
I $G(IBPRMT)'="" S DIR("A")=IBPRMT
S DIR("B")=2019
S DIR(0)="F^4:4:K:X'?4N X"
D ^DIR I $D(DIRUT) Q -1
W " ",Y
Q Y
;
PRTVSTS(IBDFN,IBYR) ; Get the list of visits for the calendar year
;
N IBZ,IBV,IBC,IBI,IBN,IBD,IBSTAT,IBDT,IBLDT,IBLDT1,IBPT,IBQUIT,IBVYR
;
S IBC=0 ; Counter of Visits
; Collect the list of visits
S IBI=0 F S IBI=$O(^IBUC(351.82,"B",IBDFN,IBI)) Q:'IBI D
. S IBD=$G(^IBUC(351.82,IBI,0))
. Q:'IBD
. S IBSTAT=$P(IBD,U,4)
. S IBDT=$P(IBD,U,3)
. S IBVYR=$E(IBDT,1,3)+1700 ; Convert visit date to calendar year
. I IBYR'=IBVYR Q
. S IBC=IBC+1
. S ^TMP($J,"IBUCVM","IBA",IBC)=IBDT,^TMP($J,"IBUCVM","IBA","D",IBDT,IBC)=IBI_U_IBD
;
;Reorganize in date order for display
S (IBLDT,IBLCT)=0
F S IBLDT=$O(^TMP($J,"IBUCVM","IBA","D",IBLDT)) Q:'IBLDT D
. S IBLDT1=0
. F S IBLDT1=$O(^TMP($J,"IBUCVM","IBA","D",IBLDT,IBLDT1)) Q:'IBLDT1 D
. . S IBLCT=IBLCT+1
. . S ^TMP($J,"IBUCVM","IBP",IBLCT)=$G(^TMP($J,"IBUCVM","IBA","D",IBLDT,IBLDT1))
;
W @IOF
S IBPT=$$PT^IBEFUNC(IBDFN)
W !,"Urgent Care Visits in "_IBYR_" for "_$P(IBPT,U),!
D LINE("=",80)
I 'IBC W "No Urgent Care Visits during this calendar year." Q 0
S IBV=IBLCT\3 I IBC#3 S IBV=IBV+1
F IBI=1:1:IBV D Q:$G(IBQUIT)
. D:$D(IBQUIT) CHKPAUSE
. S IBN=IBI
. S IBD=$G(^TMP($J,"IBUCVM","IBP",IBN))
. W !?5,$J(IBN,2),?10,$$FMTE^XLFDT($P(IBD,U,4))_" "_$S($P(IBD,U,5)=1:"F",$P(IBD,U,5)=3:"R",$P(IBD,U,5)=4:"V",1:"")
. S IBN=IBI+IBV S IBD=$G(^TMP($J,"IBUCVM","IBP",IBN)) I IBD'="" W ?30,$J(IBN,2),?35,$$FMTE^XLFDT($P(IBD,U,4))_" "_$S($P(IBD,U,5)=1:"F",$P(IBD,U,5)=3:"R",$P(IBD,U,5)=4:"V",1:"")
. S IBN=IBI+(2*IBV) S IBD=$G(^TMP($J,"IBUCVM","IBP",IBN)) I IBD'="" W ?55,$J(IBN,2),?60,$$FMTE^XLFDT($P(IBD,U,4))_" "_$S($P(IBD,U,5)=1:"F",$P(IBD,U,5)=3:"R",$P(IBD,U,5)=4:"V",1:"")
Q IBLCT
;
PAUSE(IBEND) Q:'$$SCR() ;Screen only
N IBJ,DIR,DIRUT,DTOUT,DUOUT,DIROUT,Y,IOSL2
S IBQUIT=0
Q:$E(IOST,1,2)'["C-"
S IOSL2=$S(IOSL>24:24,1:IOSL)
F IBJ=$Y:1:(IOSL2-4) W !
I $G(IBEND) S DIR("A")="Enter RETURN to continue or '^' to exit."
S DIR(0)="E"
D ^DIR
K DIR
I $G(DUOUT) S IBQUIT=1
I $G(IBEND) W @IOF
Q
;
CHKPAUSE ;Check pause
I $Y>(IOSL-5) D PAUSE Q:IBQUIT W @IOF D LINE("-",80) W !
Q
;
SCR() Q $E(IOST,1,2)="C-" ; Screen
;
; Draw a line, of characters IBC, length IBN
LINE(IBC,IBN) N IBL
I $L($G(IBC))'=1 S IBC="="
I +$G(IBN)=0 S IBN=80
S $P(IBL,IBC,IBN+1)=""
W IBL
Q
;
; Fotmatting row labels
FRM(IBLBL,IBCUT) ;
I $G(IBCUT,1) S IBLBL=$E(IBLBL,1,26)
Q " "_IBLBL_": " ;;;$J("",26-$L(IBLBL))_": "
;
;Ask the user for the type of work to do
GETMAINT() ;
;
;RCMNFLG - Ask to print the Main report (Detailed) report. 0=No, 1=Yes
N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
;
; Prompt Summary or Detail version
S DIR("A")="(A)dd an Urgent Care Visit, (E)dit an existing Visit, or (Q)uit: "
S DIR(0)="SA^A:ADD;E:Edit;Q:Quit"
S DIR("?")="Select whether to Add a new Urgent Care visit, Edit an Existing visit, or Quit."
;
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!($G(Y)="") Q -1
I Y="Q" Q -1
Q Y
;
ADDVST(IBDFN) ; Add a new UC visit for the patient
;
N IBVST,IBINST,IBSTAT,IBBILL,IBCOMM,IBSITE,IBERROR,IBDUPFLG,IBELPG,IBOVRFLG,IBIND
;
;Initialize the error return array/Variable
S IBERROR=""
;
S (IBVST,IBINST,IBSTAT,IBBILL,IBCOMM)="",IBDUPFLG=0
D SITE^IBAUTL ; retrieve the Billing Site value from the IB Site Parameter File. Store in IBSITE
S IBVST=$$GETVST
I $D(^TMP($J,"IBUCVM","IBA","D",IBVST)) S IBDUPFLG=1
Q:IBVST=-1
; Retrieve Priority Group (future development)
S IBELPG=$$GETELGP^IBECEA36(DFN,IBVST)
S IBIND=$$INDCHK^IBINUT1(IBVST,DFN) ; IB*2.0*745
;
S IBSTAT=$$GETSTAT(DFN,IBVST,IBELPG,IBIND,.IBOVRFLG) ; IB*2.0*745
Q:IBSTAT=-1
S:IBSTAT=2 IBBILL=$$GETBILL
Q:IBBILL=-1
S:IBBILL'="" IBBILL=$$UP^XLFSTR(IBBILL) ;Convert to upper case
S:IBSTAT'=2 IBCOMM=$$GETCOMM(IBSTAT,IBELPG,IBIND,IBOVRFLG) ; IB*2.0*745
Q:IBCOMM=-1
S IBOK=$$GETOK^IBECEA36(IBDUPFLG)
Q:IBOK'=1
D ADD^IBECEA38(IBDFN,IBSITE,IBVST,IBSTAT,IBBILL,IBCOMM,1,"",.IBERROR)
Q
;
EDITVST(IBLCT) ; Add a new UC visit for the patient
;
N IBSTAT,IBBILL,IBCOMM,IBERROR,IBVISIT,IBIEN,IBD,IBSITECD,IBSITENM,IBVSITE,IBVST,IBELPG,IBOK,IBOVRFLG,IBIND
;
;Ask user for visit to edit
S (IBSTAT,IBBILL,IBCOMM,IBERROR,IBVSITE,IBOVRFLG)=""
S IBVISIT=$$GETVISIT(IBLCT)
Q:IBVISIT=-1
;
;Get the visit info
S IBD=$G(^TMP($J,"IBUCVM","IBP",IBVISIT))
Q:IBD=""
S IBIEN=$P(IBD,U)
S IBVST=$P(IBD,U,4)
;
;get the Site name and code
I $P(IBD,U,3)'="" D
. S IBSITECD=$$GET1^DIQ(4,$P(IBD,U,3)_",",99,"I")
. S IBSITENM=$$GET1^DIQ(4,$P(IBD,U,3)_",",.01,"E")
. S IBVSITE=$E(IBSITECD_"-"_IBSITENM,1,20)
;
;display the visit info
;
W !!,"Date of Visit",?16,"Station",?39,"Status",?51,"Bill No.",?64,"Reason"
W !,"-------------",?16,"-------",?39,"------",?51,"--------",?64,"------"
W !,$$FMTE^XLFDT($P(IBD,U,4)),?16,IBVSITE,?39,$$GET1^DIQ(351.82,IBIEN_",",.04)
I $P(IBD,U,6)'="" W ?51,$P(IBD,U,6)
I $P(IBD,U,7)'="" W ?64,$E($$GET1^DIQ(351.82,IBIEN_",",.06),1,19)
W !!
;
; Retrieve Priority Group (future development)
S IBELPG=$$GETELGP^IBECEA36(DFN,IBVST)
S IBIND=$$INDCHK^IBINUT1(IBVST,DFN) ; IB*2.0*745
;
;Prompt for Status change
S IBSTAT=$$GETSTAT(DFN,IBVST,IBELPG,IBIND,.IBOVRFLG) ; IB*2.0*745
Q:IBSTAT=-1
;
;Prompt for Bill No. if status is billed
S:IBSTAT=2 IBBILL=$$GETBILL
Q:IBBILL=-1
S:IBBILL'="" IBBILL=$$UP^XLFSTR(IBBILL) ;Convert to upper case
;
;Prompt for Comment if changed to Free or Not Counted
S:IBSTAT'=2 IBCOMM=$$GETCOMM(IBSTAT,IBELPG,IBIND,IBOVRFLG) ; IB*2.0*745
Q:IBCOMM=-1
;
;Confirm with user with no Duplicate Visit flag.
S IBOK=$$GETOK^IBECEA36(0)
Q:IBOK'=1
;
;Save the changes.
D UPDATE^IBECEA38(IBIEN,IBSTAT,IBBILL,IBCOMM,1,.IBERROR)
Q
;
;Ask the user for the type of work to do
GETVST() ;
;
;RCMNFLG - Ask to print the Main report (Detailed) report. 0=No, 1=Yes
N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
;
; Prompt Summary or Detail version
S DIR("A")="Visit Date: "
S DIR(0)="DA^3190606:"_DT
S DIR("?")="The visit has to occur between 6/6/2019 and Today."
;
;
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!($G(Y)="") Q -1
Q Y
;
GETSTAT(IBDFN,IBVST,IBELPG,IBIND,IBOVRFLG) ;Ask the user for the Status of the Visit
;
N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT,IBFRCT,IBRUR,IBSCSA,IBY
;
;Check for the override Key
S IBOVRFLG=0
S IBFRCT=0
;
;Add Prompts
I IBAE="A" D
. S DIR("A")="(F)REE,(B)ILLED, or (V)isit Only: "
. S DIR(0)="SA^1:FREE;2:BILLED;4:VISIT ONLY"
. S DIR("?")="Select whether the visit was a FREE, BILLED, or VISIT ONLY."
;
;Edit Prompts
I IBAE="E" D
. S DIR("A")="(F)REE,(B)ILLED,(R)emoved, or (V)isit Only: "
. S DIR(0)="SA^1:FREE;2:BILLED;3:REMOVED;4:VISIT ONLY"
. S DIR("?")="Select whether the visit was a FREE, BILLED, REMOVED or VISIT ONLY."
;
D ^DIR K DIR
;
I $D(DTOUT)!$D(DUOUT)!($G(Y)="") Q -1
S IBY=Y
;
I 'IBIND,IBELPG>6,$$KCHK^XUSRB("IBUC VISIT MAINT OVERRIDE"),IBY=1 D Q:$G(Y)'=1 -1 ; IB*2.0*745
. K DIR ; reinit the DIR Array
. ; Ask user for override
. S DIR(0)="YA",DIR("A")="This veteran is not eligible for a Free Visit. Do you wish to Override? : "
. D ^DIR
. I '$G(Y)!$G(DUOUT)!$G(DTOUT)!$G(DIRUT) S Y=0 Q
. ; Confirm the override
. S DIR(0)="YA",DIR("A")="Are you sure? "
. D ^DIR
. I '$G(Y)!$G(DUOUT)!$G(DTOUT)!$G(DIRUT) S Y=0 Q
. S:$G(Y)=1 IBOVRFLG=1 ; Set override Flag to yes
;
;Validate that the veteran can receive a free visit
I 'IBIND,IBELPG>6,IBY=1,'IBOVRFLG D Q -1 ; IB*2.0*745
. W !!,"Per the MISSION Act of 2018, this patient is ineligible for a Free"
. W !,"Urgent Care Visit.",!
;
I 'IBIND,IBELPG=6 D ; IB*2.0*745
. ;Check to see if an RUR was completed. If not, ask for the RUR and quit
. S IBRUR=$$PRTSARUR^IBECEA36
. I IBRUR=-1 D Q
. . W !!,"Please send this for review by RUR."
. . S IBY=-1
. ;
. ;Check to see if visit related to the SC/SA.
. S IBSCSA=$$PRTVSTSA^IBECEA36
. ;
. I (IBSCSA=-1),(IBY=1) D
. . W !!,"Per the MISSION Act of 2018, this patient is ineligible for a Free"
. . W !,"Urgent Care Visit.",!
. . S IBY=-1
;
; Exit if the PG 6 data checks failed
I IBY=-1 Q -1
;
; If a free visit, check to see if there are already 3 or more visits. If so warn the user and exit.
S:IBY=1 IBFRCT=$P($$GETVST^IBECEA36(IBDFN,IBVST),U,2)
;
K ^TMP($J,"IBUCVST") ;Clean up TMP global created during GETVST^IBECEA36, not needed
;
I (IBY=1),((IBELPG<7)!(IBOVRFLG=1)),(IBFRCT>2) D Q -1
. W !!,"Per the Mission Act of 2018, this patient has already used their 3 free"
. W !,"visits for the calendar year.",!
Q IBY ; IB*2.0*745
;
GETBILL() ;Ask the user for a Bill Number
;
N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
;
S DIR("A")="Bill Number: "
S DIR(0)="FAO^^S X=$$UP^XLFSTR(X) K:'$$CHKBILL^IBUCVM(X) X"
S DIR("?")="Enter the Bill Number (including site) or ON HOLD if this visit was billed. <ENTER> to continue."
;
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) Q -1
Q Y
;
CHKBILL(IBBLNO) ; Validate that the Bill Number is a valid input
;
;Input: IBBLNO - A bill number (with site) or ON HOLD.
;
N IBBLIEN
;
Q:IBBLNO="ON HOLD" 1 ; ON HOLD is a valid non Bill # entry
I IBBLNO'?3N1"-"1"K"6NU Q 0 ; Is not a valid Site and Bill Number format
S IBBLIEN=$O(^IB("ABIL",IBBLNO,""))
Q:IBBLIEN'="" 1
Q 0
;
GETCOMM(IBSTAT,IBELPG,IBIND,IBOVRFLG) ; Ask the user for the status reason (or default it if Status is FREE)
;
;Input: IBSTAT - The visit status (from code set in .06 field in file 351.82
; 1 - FREE
; 3 - REMOVED
; 4 - VISIT ONLY
;
N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
;
;
;If the status is to be FREE, auto populate the Reason based on Priority Group
I IBSTAT=1,IBELPG=6 Q 1 ;Defaults to reason SC/SA
I IBSTAT=1,IBELPG<6!IBIND Q 2 ;Defaults to reason MISSION Act IB*2.0*745
I IBSTAT=1,IBOVRFLG=1 Q 6 ;Defaults to reason FRM Override
;
;If the status is VISIT ONLy, auto populate the Reason with No Copay Required
I IBSTAT=4 Q 5
;
;If the Status is Not Counted, ask user for the REMOVED reason.
S DIR("A")="Reason for (E)ntered in Error or (D)uplicate Visit: "
S DIR(0)="SA^3:Entered in Error;4:Duplicate Visit"
S DIR("?")="Select a reason to associate with the REMOVED visit status."
;
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) Q -1
Q Y
;
GETVISIT(IBLCT) ; Get the IEN for visit to be edited.
;
S DIR("A")="Enter Visit Number: "
S DIR(0)="NA^1:"_IBLCT_"^"
S DIR("?")="Enter the Visit to edit from the list above"
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y<1) Q -1
;
Q +Y
;
DISPCHG(IBSTAT,IBBILL,IBREAS) ;Redisplay the changes requested
;
W "The following updates will be made to this visit:"
W !!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBUCVM 12308 printed Nov 22, 2024@17:39:24 Page 2
IBUCVM ;LL/ELZ-LONG TERM CARE CLOCK MAINTANCE ; 06-DEC-19
+1 ;;2.0;INTEGRATED BILLING;**663,671,669,675,745**;21-MAR-94;Build 8
+2 ;; Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; This routine is used to perform the Urgent Care Visit Tracking
+5 ; database Maintenance.
+6 ;
+7 QUIT
+8 ;
ENTER ; menu option main entry point
+1 ;
+2 NEW DIC,X,Y,DFN,DTOUT,DUOUT,DIRUT,DIROUT,%,DIR,IBYR,IBLCT,IBAE,IBQUIT
+3 ;
+4 ;Don't quit.
SET IBQUIT=0
+5 ;
+6 ; select a patient (screen out patients with no LTC clock and are
+7 ; not LTC patients.
LOOP KILL DIC,X,Y,DFN,IBLTCX,VADP,IBLCT
+1 ;
+2 ; Clear temp global in case of stoppage during work
+3 KILL ^TMP($JOB,"IBUCVM")
+4 ;
+5 ;Ask for the patient
+6 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+7 SET DIC="^DPT("
SET DIC(0)="AEMNQ"
WRITE !
DO ^DIC
if Y<1
GOTO EX
+8 SET DFN=+Y
DO DEM^VADPT
+9 ;
+10 SET IBYR=$$ASKDT("Enter Year")
+11 if IBYR=-1
GOTO LOOP
+12 ;
MLOOP ; Entry/Loop tag to allow user to stay with the defined maintenance utility.
+1 ;
+2 SET IBLCT=$$PRTVSTS(DFN,IBYR)
+3 ;
+4 ;Ask user to Add or Edit Visit
+5 ; Space prompt.
WRITE !!
+6 SET IBAE=$$GETMAINT
+7 IF IBAE=-1
GOTO LOOP
+8 ;
+9 IF IBAE="A"
DO ADDVST(DFN)
+10 IF IBAE="E"
DO EDITVST(IBLCT)
+11 ;
+12 DO PAUSE(1)
+13 ;
+14 IF IBQUIT=1
GOTO LOOP
+15 ; Clear temp global after work on the veteran is done.
+16 KILL ^TMP($JOB,"IBUCVM")
+17 GOTO MLOOP
+18 ;
EX ;
+1 DO KVAR^VADPT
+2 ;
+3 QUIT
+4 ;
ASKDT(IBPRMT) ;Date input
+1 NEW DIR,Y,X,DIROUT,DIRUT
+2 IF $GET(IBPRMT)'=""
SET DIR("A")=IBPRMT
+3 SET DIR("B")=2019
+4 SET DIR(0)="F^4:4:K:X'?4N X"
+5 DO ^DIR
IF $DATA(DIRUT)
QUIT -1
+6 WRITE " ",Y
+7 QUIT Y
+8 ;
PRTVSTS(IBDFN,IBYR) ; Get the list of visits for the calendar year
+1 ;
+2 NEW IBZ,IBV,IBC,IBI,IBN,IBD,IBSTAT,IBDT,IBLDT,IBLDT1,IBPT,IBQUIT,IBVYR
+3 ;
+4 ; Counter of Visits
SET IBC=0
+5 ; Collect the list of visits
+6 SET IBI=0
FOR
SET IBI=$ORDER(^IBUC(351.82,"B",IBDFN,IBI))
if 'IBI
QUIT
Begin DoDot:1
+7 SET IBD=$GET(^IBUC(351.82,IBI,0))
+8 if 'IBD
QUIT
+9 SET IBSTAT=$PIECE(IBD,U,4)
+10 SET IBDT=$PIECE(IBD,U,3)
+11 ; Convert visit date to calendar year
SET IBVYR=$EXTRACT(IBDT,1,3)+1700
+12 IF IBYR'=IBVYR
QUIT
+13 SET IBC=IBC+1
+14 SET ^TMP($JOB,"IBUCVM","IBA",IBC)=IBDT
SET ^TMP($JOB,"IBUCVM","IBA","D",IBDT,IBC)=IBI_U_IBD
End DoDot:1
+15 ;
+16 ;Reorganize in date order for display
+17 SET (IBLDT,IBLCT)=0
+18 FOR
SET IBLDT=$ORDER(^TMP($JOB,"IBUCVM","IBA","D",IBLDT))
if 'IBLDT
QUIT
Begin DoDot:1
+19 SET IBLDT1=0
+20 FOR
SET IBLDT1=$ORDER(^TMP($JOB,"IBUCVM","IBA","D",IBLDT,IBLDT1))
if 'IBLDT1
QUIT
Begin DoDot:2
+21 SET IBLCT=IBLCT+1
+22 SET ^TMP($JOB,"IBUCVM","IBP",IBLCT)=$GET(^TMP($JOB,"IBUCVM","IBA","D",IBLDT,IBLDT1))
End DoDot:2
End DoDot:1
+23 ;
+24 WRITE @IOF
+25 SET IBPT=$$PT^IBEFUNC(IBDFN)
+26 WRITE !,"Urgent Care Visits in "_IBYR_" for "_$PIECE(IBPT,U),!
+27 DO LINE("=",80)
+28 IF 'IBC
WRITE "No Urgent Care Visits during this calendar year."
QUIT 0
+29 SET IBV=IBLCT\3
IF IBC#3
SET IBV=IBV+1
+30 FOR IBI=1:1:IBV
Begin DoDot:1
+31 if $DATA(IBQUIT)
DO CHKPAUSE
+32 SET IBN=IBI
+33 SET IBD=$GET(^TMP($JOB,"IBUCVM","IBP",IBN))
+34 WRITE !?5,$JUSTIFY(IBN,2),?10,$$FMTE^XLFDT($PIECE(IBD,U,4))_" "_$SELECT($PIECE(IBD,U,5)=1:"F",$PIECE(IBD,U,5)=3:"R",$PIECE(IBD,U,5)=4:"V",1:"")
+35 SET IBN=IBI+IBV
SET IBD=$GET(^TMP($JOB,"IBUCVM","IBP",IBN))
IF IBD'=""
WRITE ?30,$JUSTIFY(IBN,2),?35,$$FMTE^XLFDT($PIECE(IBD,U,4))_" "_$SELECT($PIECE(IBD,U,5)=1:"F",$PIECE(IBD,U,5)=3:"R",$PIECE(IBD,U,5)=4:"V",1:"")
+36 SET IBN=IBI+(2*IBV)
SET IBD=$GET(^TMP($JOB,"IBUCVM","IBP",IBN))
IF IBD'=""
WRITE ?55,$JUSTIFY(IBN,2),?60,$$FMTE^XLFDT($PIECE(IBD,U,4))_" "_$SELECT($PIECE(IBD,U,5)=1:"F",$PIECE(IBD,U,5)=3:"R",$PIECE(IBD,U,5)=4:"V",1:"")
End DoDot:1
if $GET(IBQUIT)
QUIT
+37 QUIT IBLCT
+38 ;
PAUSE(IBEND) ;Screen only
if '$$SCR()
QUIT
+1 NEW IBJ,DIR,DIRUT,DTOUT,DUOUT,DIROUT,Y,IOSL2
+2 SET IBQUIT=0
+3 if $EXTRACT(IOST,1,2)'["C-"
QUIT
+4 SET IOSL2=$SELECT(IOSL>24:24,1:IOSL)
+5 FOR IBJ=$Y:1:(IOSL2-4)
WRITE !
+6 IF $GET(IBEND)
SET DIR("A")="Enter RETURN to continue or '^' to exit."
+7 SET DIR(0)="E"
+8 DO ^DIR
+9 KILL DIR
+10 IF $GET(DUOUT)
SET IBQUIT=1
+11 IF $GET(IBEND)
WRITE @IOF
+12 QUIT
+13 ;
CHKPAUSE ;Check pause
+1 IF $Y>(IOSL-5)
DO PAUSE
if IBQUIT
QUIT
WRITE @IOF
DO LINE("-",80)
WRITE !
+2 QUIT
+3 ;
SCR() ; Screen
QUIT $EXTRACT(IOST,1,2)="C-"
+1 ;
+2 ; Draw a line, of characters IBC, length IBN
LINE(IBC,IBN) NEW IBL
+1 IF $LENGTH($GET(IBC))'=1
SET IBC="="
+2 IF +$GET(IBN)=0
SET IBN=80
+3 SET $PIECE(IBL,IBC,IBN+1)=""
+4 WRITE IBL
+5 QUIT
+6 ;
+7 ; Fotmatting row labels
FRM(IBLBL,IBCUT) ;
+1 IF $GET(IBCUT,1)
SET IBLBL=$EXTRACT(IBLBL,1,26)
+2 ;;;$J("",26-$L(IBLBL))_": "
QUIT " "_IBLBL_": "
+3 ;
+4 ;Ask the user for the type of work to do
GETMAINT() ;
+1 ;
+2 ;RCMNFLG - Ask to print the Main report (Detailed) report. 0=No, 1=Yes
+3 NEW X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
+4 ;
+5 ; Prompt Summary or Detail version
+6 SET DIR("A")="(A)dd an Urgent Care Visit, (E)dit an existing Visit, or (Q)uit: "
+7 SET DIR(0)="SA^A:ADD;E:Edit;Q:Quit"
+8 SET DIR("?")="Select whether to Add a new Urgent Care visit, Edit an Existing visit, or Quit."
+9 ;
+10 DO ^DIR
KILL DIR
+11 IF $DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)="")
QUIT -1
+12 IF Y="Q"
QUIT -1
+13 QUIT Y
+14 ;
ADDVST(IBDFN) ; Add a new UC visit for the patient
+1 ;
+2 NEW IBVST,IBINST,IBSTAT,IBBILL,IBCOMM,IBSITE,IBERROR,IBDUPFLG,IBELPG,IBOVRFLG,IBIND
+3 ;
+4 ;Initialize the error return array/Variable
+5 SET IBERROR=""
+6 ;
+7 SET (IBVST,IBINST,IBSTAT,IBBILL,IBCOMM)=""
SET IBDUPFLG=0
+8 ; retrieve the Billing Site value from the IB Site Parameter File. Store in IBSITE
DO SITE^IBAUTL
+9 SET IBVST=$$GETVST
+10 IF $DATA(^TMP($JOB,"IBUCVM","IBA","D",IBVST))
SET IBDUPFLG=1
+11 if IBVST=-1
QUIT
+12 ; Retrieve Priority Group (future development)
+13 SET IBELPG=$$GETELGP^IBECEA36(DFN,IBVST)
+14 ; IB*2.0*745
SET IBIND=$$INDCHK^IBINUT1(IBVST,DFN)
+15 ;
+16 ; IB*2.0*745
SET IBSTAT=$$GETSTAT(DFN,IBVST,IBELPG,IBIND,.IBOVRFLG)
+17 if IBSTAT=-1
QUIT
+18 if IBSTAT=2
SET IBBILL=$$GETBILL
+19 if IBBILL=-1
QUIT
+20 ;Convert to upper case
if IBBILL'=""
SET IBBILL=$$UP^XLFSTR(IBBILL)
+21 ; IB*2.0*745
if IBSTAT'=2
SET IBCOMM=$$GETCOMM(IBSTAT,IBELPG,IBIND,IBOVRFLG)
+22 if IBCOMM=-1
QUIT
+23 SET IBOK=$$GETOK^IBECEA36(IBDUPFLG)
+24 if IBOK'=1
QUIT
+25 DO ADD^IBECEA38(IBDFN,IBSITE,IBVST,IBSTAT,IBBILL,IBCOMM,1,"",.IBERROR)
+26 QUIT
+27 ;
EDITVST(IBLCT) ; Add a new UC visit for the patient
+1 ;
+2 NEW IBSTAT,IBBILL,IBCOMM,IBERROR,IBVISIT,IBIEN,IBD,IBSITECD,IBSITENM,IBVSITE,IBVST,IBELPG,IBOK,IBOVRFLG,IBIND
+3 ;
+4 ;Ask user for visit to edit
+5 SET (IBSTAT,IBBILL,IBCOMM,IBERROR,IBVSITE,IBOVRFLG)=""
+6 SET IBVISIT=$$GETVISIT(IBLCT)
+7 if IBVISIT=-1
QUIT
+8 ;
+9 ;Get the visit info
+10 SET IBD=$GET(^TMP($JOB,"IBUCVM","IBP",IBVISIT))
+11 if IBD=""
QUIT
+12 SET IBIEN=$PIECE(IBD,U)
+13 SET IBVST=$PIECE(IBD,U,4)
+14 ;
+15 ;get the Site name and code
+16 IF $PIECE(IBD,U,3)'=""
Begin DoDot:1
+17 SET IBSITECD=$$GET1^DIQ(4,$PIECE(IBD,U,3)_",",99,"I")
+18 SET IBSITENM=$$GET1^DIQ(4,$PIECE(IBD,U,3)_",",.01,"E")
+19 SET IBVSITE=$EXTRACT(IBSITECD_"-"_IBSITENM,1,20)
End DoDot:1
+20 ;
+21 ;display the visit info
+22 ;
+23 WRITE !!,"Date of Visit",?16,"Station",?39,"Status",?51,"Bill No.",?64,"Reason"
+24 WRITE !,"-------------",?16,"-------",?39,"------",?51,"--------",?64,"------"
+25 WRITE !,$$FMTE^XLFDT($PIECE(IBD,U,4)),?16,IBVSITE,?39,$$GET1^DIQ(351.82,IBIEN_",",.04)
+26 IF $PIECE(IBD,U,6)'=""
WRITE ?51,$PIECE(IBD,U,6)
+27 IF $PIECE(IBD,U,7)'=""
WRITE ?64,$EXTRACT($$GET1^DIQ(351.82,IBIEN_",",.06),1,19)
+28 WRITE !!
+29 ;
+30 ; Retrieve Priority Group (future development)
+31 SET IBELPG=$$GETELGP^IBECEA36(DFN,IBVST)
+32 ; IB*2.0*745
SET IBIND=$$INDCHK^IBINUT1(IBVST,DFN)
+33 ;
+34 ;Prompt for Status change
+35 ; IB*2.0*745
SET IBSTAT=$$GETSTAT(DFN,IBVST,IBELPG,IBIND,.IBOVRFLG)
+36 if IBSTAT=-1
QUIT
+37 ;
+38 ;Prompt for Bill No. if status is billed
+39 if IBSTAT=2
SET IBBILL=$$GETBILL
+40 if IBBILL=-1
QUIT
+41 ;Convert to upper case
if IBBILL'=""
SET IBBILL=$$UP^XLFSTR(IBBILL)
+42 ;
+43 ;Prompt for Comment if changed to Free or Not Counted
+44 ; IB*2.0*745
if IBSTAT'=2
SET IBCOMM=$$GETCOMM(IBSTAT,IBELPG,IBIND,IBOVRFLG)
+45 if IBCOMM=-1
QUIT
+46 ;
+47 ;Confirm with user with no Duplicate Visit flag.
+48 SET IBOK=$$GETOK^IBECEA36(0)
+49 if IBOK'=1
QUIT
+50 ;
+51 ;Save the changes.
+52 DO UPDATE^IBECEA38(IBIEN,IBSTAT,IBBILL,IBCOMM,1,.IBERROR)
+53 QUIT
+54 ;
+55 ;Ask the user for the type of work to do
GETVST() ;
+1 ;
+2 ;RCMNFLG - Ask to print the Main report (Detailed) report. 0=No, 1=Yes
+3 NEW X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
+4 ;
+5 ; Prompt Summary or Detail version
+6 SET DIR("A")="Visit Date: "
+7 SET DIR(0)="DA^3190606:"_DT
+8 SET DIR("?")="The visit has to occur between 6/6/2019 and Today."
+9 ;
+10 ;
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)="")
QUIT -1
+13 QUIT Y
+14 ;
GETSTAT(IBDFN,IBVST,IBELPG,IBIND,IBOVRFLG) ;Ask the user for the Status of the Visit
+1 ;
+2 NEW X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT,IBFRCT,IBRUR,IBSCSA,IBY
+3 ;
+4 ;Check for the override Key
+5 SET IBOVRFLG=0
+6 SET IBFRCT=0
+7 ;
+8 ;Add Prompts
+9 IF IBAE="A"
Begin DoDot:1
+10 SET DIR("A")="(F)REE,(B)ILLED, or (V)isit Only: "
+11 SET DIR(0)="SA^1:FREE;2:BILLED;4:VISIT ONLY"
+12 SET DIR("?")="Select whether the visit was a FREE, BILLED, or VISIT ONLY."
End DoDot:1
+13 ;
+14 ;Edit Prompts
+15 IF IBAE="E"
Begin DoDot:1
+16 SET DIR("A")="(F)REE,(B)ILLED,(R)emoved, or (V)isit Only: "
+17 SET DIR(0)="SA^1:FREE;2:BILLED;3:REMOVED;4:VISIT ONLY"
+18 SET DIR("?")="Select whether the visit was a FREE, BILLED, REMOVED or VISIT ONLY."
End DoDot:1
+19 ;
+20 DO ^DIR
KILL DIR
+21 ;
+22 IF $DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)="")
QUIT -1
+23 SET IBY=Y
+24 ;
+25 ; IB*2.0*745
IF 'IBIND
IF IBELPG>6
IF $$KCHK^XUSRB("IBUC VISIT MAINT OVERRIDE")
IF IBY=1
Begin DoDot:1
+26 ; reinit the DIR Array
KILL DIR
+27 ; Ask user for override
+28 SET DIR(0)="YA"
SET DIR("A")="This veteran is not eligible for a Free Visit. Do you wish to Override? : "
+29 DO ^DIR
+30 IF '$GET(Y)!$GET(DUOUT)!$GET(DTOUT)!$GET(DIRUT)
SET Y=0
QUIT
+31 ; Confirm the override
+32 SET DIR(0)="YA"
SET DIR("A")="Are you sure? "
+33 DO ^DIR
+34 IF '$GET(Y)!$GET(DUOUT)!$GET(DTOUT)!$GET(DIRUT)
SET Y=0
QUIT
+35 ; Set override Flag to yes
if $GET(Y)=1
SET IBOVRFLG=1
End DoDot:1
if $GET(Y)'=1
QUIT -1
+36 ;
+37 ;Validate that the veteran can receive a free visit
+38 ; IB*2.0*745
IF 'IBIND
IF IBELPG>6
IF IBY=1
IF 'IBOVRFLG
Begin DoDot:1
+39 WRITE !!,"Per the MISSION Act of 2018, this patient is ineligible for a Free"
+40 WRITE !,"Urgent Care Visit.",!
End DoDot:1
QUIT -1
+41 ;
+42 ; IB*2.0*745
IF 'IBIND
IF IBELPG=6
Begin DoDot:1
+43 ;Check to see if an RUR was completed. If not, ask for the RUR and quit
+44 SET IBRUR=$$PRTSARUR^IBECEA36
+45 IF IBRUR=-1
Begin DoDot:2
+46 WRITE !!,"Please send this for review by RUR."
+47 SET IBY=-1
End DoDot:2
QUIT
+48 ;
+49 ;Check to see if visit related to the SC/SA.
+50 SET IBSCSA=$$PRTVSTSA^IBECEA36
+51 ;
+52 IF (IBSCSA=-1)
IF (IBY=1)
Begin DoDot:2
+53 WRITE !!,"Per the MISSION Act of 2018, this patient is ineligible for a Free"
+54 WRITE !,"Urgent Care Visit.",!
+55 SET IBY=-1
End DoDot:2
End DoDot:1
+56 ;
+57 ; Exit if the PG 6 data checks failed
+58 IF IBY=-1
QUIT -1
+59 ;
+60 ; If a free visit, check to see if there are already 3 or more visits. If so warn the user and exit.
+61 if IBY=1
SET IBFRCT=$PIECE($$GETVST^IBECEA36(IBDFN,IBVST),U,2)
+62 ;
+63 ;Clean up TMP global created during GETVST^IBECEA36, not needed
KILL ^TMP($JOB,"IBUCVST")
+64 ;
+65 IF (IBY=1)
IF ((IBELPG<7)!(IBOVRFLG=1))
IF (IBFRCT>2)
Begin DoDot:1
+66 WRITE !!,"Per the Mission Act of 2018, this patient has already used their 3 free"
+67 WRITE !,"visits for the calendar year.",!
End DoDot:1
QUIT -1
+68 ; IB*2.0*745
QUIT IBY
+69 ;
GETBILL() ;Ask the user for a Bill Number
+1 ;
+2 NEW X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
+3 ;
+4 SET DIR("A")="Bill Number: "
+5 SET DIR(0)="FAO^^S X=$$UP^XLFSTR(X) K:'$$CHKBILL^IBUCVM(X) X"
+6 SET DIR("?")="Enter the Bill Number (including site) or ON HOLD if this visit was billed. <ENTER> to continue."
+7 ;
+8 DO ^DIR
KILL DIR
+9 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT -1
+10 QUIT Y
+11 ;
CHKBILL(IBBLNO) ; Validate that the Bill Number is a valid input
+1 ;
+2 ;Input: IBBLNO - A bill number (with site) or ON HOLD.
+3 ;
+4 NEW IBBLIEN
+5 ;
+6 ; ON HOLD is a valid non Bill # entry
if IBBLNO="ON HOLD"
QUIT 1
+7 ; Is not a valid Site and Bill Number format
IF IBBLNO'?3N1"-"1"K"6NU
QUIT 0
+8 SET IBBLIEN=$ORDER(^IB("ABIL",IBBLNO,""))
+9 if IBBLIEN'=""
QUIT 1
+10 QUIT 0
+11 ;
GETCOMM(IBSTAT,IBELPG,IBIND,IBOVRFLG) ; Ask the user for the status reason (or default it if Status is FREE)
+1 ;
+2 ;Input: IBSTAT - The visit status (from code set in .06 field in file 351.82
+3 ; 1 - FREE
+4 ; 3 - REMOVED
+5 ; 4 - VISIT ONLY
+6 ;
+7 NEW X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
+8 ;
+9 ;
+10 ;If the status is to be FREE, auto populate the Reason based on Priority Group
+11 ;Defaults to reason SC/SA
IF IBSTAT=1
IF IBELPG=6
QUIT 1
+12 ;Defaults to reason MISSION Act IB*2.0*745
IF IBSTAT=1
IF IBELPG<6!IBIND
QUIT 2
+13 ;Defaults to reason FRM Override
IF IBSTAT=1
IF IBOVRFLG=1
QUIT 6
+14 ;
+15 ;If the status is VISIT ONLy, auto populate the Reason with No Copay Required
+16 IF IBSTAT=4
QUIT 5
+17 ;
+18 ;If the Status is Not Counted, ask user for the REMOVED reason.
+19 SET DIR("A")="Reason for (E)ntered in Error or (D)uplicate Visit: "
+20 SET DIR(0)="SA^3:Entered in Error;4:Duplicate Visit"
+21 SET DIR("?")="Select a reason to associate with the REMOVED visit status."
+22 ;
+23 DO ^DIR
KILL DIR
+24 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT -1
+25 QUIT Y
+26 ;
GETVISIT(IBLCT) ; Get the IEN for visit to be edited.
+1 ;
+2 SET DIR("A")="Enter Visit Number: "
+3 SET DIR(0)="NA^1:"_IBLCT_"^"
+4 SET DIR("?")="Enter the Visit to edit from the list above"
+5 DO ^DIR
KILL DIR
+6 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<1)
QUIT -1
+7 ;
+8 QUIT +Y
+9 ;
DISPCHG(IBSTAT,IBBILL,IBREAS) ;Redisplay the changes requested
+1 ;
+2 WRITE "The following updates will be made to this visit:"
+3 WRITE !!
+4 QUIT
