IBMHVM ;EDE/YMG - Mental Health Visit Maintenance; 07/06/2023
;;2.0;INTEGRATED BILLING;**784**;21-MAR-94;Build 8
;; Per VHA Directive 6402, this routine should not be modified
;
; This routine is used to perform the Mental Health Visit Tracking
; database Maintenance.
;
Q
;
EN ; entry point
N DIC,X,Y,DFN,DTOUT,DUOUT,DIRUT,DIROUT,%,DIR,IBYR,IBLCT,IBAE,IBQUIT
;
S IBQUIT=0
LOOP K DIC,X,Y,DFN,IBLTCX,VADP,IBLCT
K ^TMP($J,"IBMHVM")
;
;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 !!
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,"IBMHVM")
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")=2023
S DIR(0)="F^4:4^K:X'?4N X"
D ^DIR I $D(DIRUT)!$D(DIROUT) 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(^IBMH(351.83,"B",IBDFN,IBI)) Q:'IBI D
.S IBD=$G(^IBMH(351.83,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,"IBMHVM","IBA",IBC)=IBDT,^TMP($J,"IBMHVM","IBA","D",IBDT,IBC)=IBI_U_IBD
.Q
;
;Reorganize in date order for display
S (IBLDT,IBLCT)=0 F S IBLDT=$O(^TMP($J,"IBMHVM","IBA","D",IBLDT)) Q:'IBLDT D
.S IBLDT1=0 F S IBLDT1=$O(^TMP($J,"IBMHVM","IBA","D",IBLDT,IBLDT1)) Q:'IBLDT1 D
..S IBLCT=IBLCT+1
..S ^TMP($J,"IBMHVM","IBP",IBLCT)=$G(^TMP($J,"IBMHVM","IBA","D",IBLDT,IBLDT1))
..Q
;
W @IOF
S IBPT=$$PT^IBEFUNC(IBDFN)
W !,"Mental Health Visits in "_IBYR_" for "_$P(IBPT,U),!
D LINE("=",80)
I 'IBC W "No Mental Health 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,"IBMHVM","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,"IBMHVM","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,"IBMHVM","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
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() ;
N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
; Prompt Summary or Detail version
S DIR("A")="(A)dd a Mental Health 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 Mental Health 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 MH visit for the patient
N IBVST,IBIEN,IBSTAT,IBCOMM,IBSITE,IBDUPFLG,IBOVRFLG,IBIND
;
S (IBIEN,IBVST,IBSTAT,IBCOMM)="",IBDUPFLG=0
D SITE^IBAUTL ; retrieve the Billing Site value from the IB Site Parameter File. Store in IBSITE
S IBVST=$$GETVST() Q:IBVST=-1
I $D(^TMP($J,"IBMHVM","IBA","D",IBVST)) S IBDUPFLG=1
S IBIND=$$INDCHK^IBINUT1(IBVST,DFN)
S IBSTAT=$$GETSTAT(DFN,IBVST,IBIND,.IBOVRFLG) Q:IBSTAT=-1
I IBSTAT=2 S IBIEN=$$GETBILL(DFN,IBVST) I 'IBIEN W !,"No Cleland-Dole eligible charge was found for this date." Q
S:IBSTAT'=2 IBCOMM=$$GETCOMM(IBSTAT,IBOVRFLG)
Q:IBCOMM=-1
S IBOK=$$GETOK^IBECEA36(IBDUPFLG) Q:IBOK'=1
D ADDVST^IBECEAMH(IBDFN,IBVST,IBIEN,IBSTAT,IBCOMM,IBSITE)
Q
;
EDITVST(IBLCT) ; Edit an existing MH visit for the patient
N IBSTAT,IBVISIT,IBIEN,IBD,IBSITECD,IBSITENM,IBVSITE,IBVST,IBVSTIEN,IBOK,IBOVRFLG,IBIND,IBCOMM
; Ask user for visit to edit
S (IBSTAT,IBVSITE,IBOVRFLG)=""
S IBVISIT=$$GETVISIT(IBLCT)
Q:IBVISIT=-1
; Get the visit info
S IBD=$G(^TMP($J,"IBMHVM","IBP",IBVISIT)) Q:IBD=""
S IBVSTIEN=$P(IBD,U),IBVST=$P(IBD,U,4),IBIEN=$P(IBD,U,9)
; 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)
.Q
; 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.83,IBVSTIEN,.04)
I $P(IBD,U,6)'="" W ?51,$P(IBD,U,6)
I $P(IBD,U,7)'="" W ?64,$E($$GET1^DIQ(351.83,IBVSTIEN,.06),1,19)
W !!
S IBIND=$$INDCHK^IBINUT1(IBVST,DFN)
; Prompt for Status change
S IBSTAT=$$GETSTAT(DFN,IBVST,IBIND,.IBOVRFLG)
Q:IBSTAT=-1
I $$CHKDUP(IBSTAT,IBVSTIEN) W !!,"Visit can only be edited to a different status." Q
S IBCOMM=0 I IBSTAT=4 S IBCOMM=$$GETCOMM(IBSTAT,IBOVRFLG) S:IBCOMM=3 IBSTAT=1
; Confirm with user with no Duplicate Visit flag.
S IBOK=$$GETOK^IBECEA36(0)
Q:IBOK'=1
; Save the changes.
D UPDVST^IBECEAMH(IBIEN,IBSTAT,IBVSTIEN)
Q
;
;Ask the user for the type of work to do
GETVST() ;
N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
N SDT
S SDT=$$GET1^DIQ(350.9,"1,",71.03,"I")
S DIR("A")="Visit Date: "
S DIR(0)="DA^"_SDT_":"_DT
S DIR("?")="The visit has to occur between "_$$FMTE^XLFDT(SDT,"2DZ")_" and Today."
D ^DIR
I $D(DTOUT)!$D(DUOUT)!($G(Y)="") Q -1
Q Y
;
GETSTAT(IBDFN,IBVST,IBIND,IBOVRFLG) ;Ask the user for the Status of the Visit
;
N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT,IBRUR,IBSCSA,IBY
;
S IBOVRFLG=0
I IBAE="A",IBIND D Q -1
.W !!,"Unable to add visit for patient covered by Indian Attestation exemption.",!
.Q
;Add Prompt
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."
.Q
;Edit Prompt
I IBAE="E" D
.S DIR("A")="(F)REE, (R)emoved, or (V)isit Only: "
.S DIR(0)="SA^3:FREE;4:REMOVED;2:VISIT ONLY"
.S DIR("?")="Select whether the visit was a FREE, REMOVED or VISIT ONLY."
.Q
;
D ^DIR K DIR
;
I $D(DTOUT)!$D(DUOUT)!($G(Y)="") Q -1
S IBY=Y
;
; If a free visit, check to see if there are already 3 or more visits. If so warn the user and exit.
I IBY=1,'$$NUMVSTCK^IBECEAMH(IBDFN,IBVST) D Q -1
.W !!,"Per the Cleland-Dole Act, this patient has already used their 3 free"
.W !,"visits for the calendar year.",!
.Q
Q IBY
;
GETCOMM(IBSTAT,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.83
; 1 - FREE
; 2 - VISIT ONLY
; 4 - REMOVED
;
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,IBOVRFLG=1 Q 6 ; Defaults to reason FRM Override
I IBSTAT=1 Q 2 ; Defaults to reason Cleland-Dole
; If the status is VISIT ONLY, auto populate the Reason with No Copay Required
I IBSTAT=2 Q 5
; 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
;
GETBILL(IBDFN,IBVSTDT) ; get bill # from file 350
;
; IBDFN - patient's DFN
; IBVSTDT - visit date
;
; returns file 350 ien, or 0 if no file 350 entry was found.
;
N IBENC,IBIEN,IBOK,IBSTAT,N0,STOP,RES,Z
S (RES,STOP)=0
S IBIEN="" F S IBIEN=$O(^IB("ACHDT",IBDFN,IBVSTDT,IBIEN)) Q:'IBIEN!STOP D
.S IBSTAT=$$GET1^DIQ(350,IBIEN,.05) I IBSTAT="CANCELLED" Q
.S N0=$G(^IB(IBIEN,0))
.S IBOK=$$ISCDCANC^IBECEAMH(IBIEN)
.I 'IBOK S Z=$P($P(N0,U,4),";") Q:$P(Z,":")'="409.68" S IBENC=$P(Z,":",2),IBOK=$$OECHK^IBECEAMH(IBENC,IBVSTDT)
.I 'IBOK Q ; not Cleland-Dole eligible
.S RES=IBIEN,STOP=1
.Q
Q RES
;
CHKDUP(IBSTAT,IBVSTIEN) ; check for duplicate visit status
;
; IBSTAT - new visit status (from $$GETSTAT() function)
; IBVSTIEN - file 351.83 ien
;
; returns 1 if new status is the same as existing one, 0 otherwise
;
N TMP
S TMP=$S(IBSTAT=3:1,IBSTAT=4:3,1:4) ; convert $$GETSTAT() result to appropriate code for field 351.83/.04
I $$GET1^DIQ(351.83,IBVSTIEN,.04,"I")=TMP Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBMHVM 10115 printed Apr 09, 2024@21:12:53 Page 2
IBMHVM ;EDE/YMG - Mental Health Visit Maintenance; 07/06/2023
+1 ;;2.0;INTEGRATED BILLING;**784**;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 Mental Health Visit Tracking
+5 ; database Maintenance.
+6 ;
+7 QUIT
+8 ;
EN ; entry point
+1 NEW DIC,X,Y,DFN,DTOUT,DUOUT,DIRUT,DIROUT,%,DIR,IBYR,IBLCT,IBAE,IBQUIT
+2 ;
+3 SET IBQUIT=0
LOOP KILL DIC,X,Y,DFN,IBLTCX,VADP,IBLCT
+1 KILL ^TMP($JOB,"IBMHVM")
+2 ;
+3 ;Ask for the patient
+4 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+5 SET DIC="^DPT("
SET DIC(0)="AEMNQ"
WRITE !
DO ^DIC
if Y<1
GOTO EX
+6 SET DFN=+Y
DO DEM^VADPT
+7 ;
+8 SET IBYR=$$ASKDT("Enter Year")
+9 if IBYR=-1
GOTO LOOP
+10 ;
MLOOP ; Entry/Loop tag to allow user to stay with the defined maintenance utility.
+1 ;
+2 SET IBLCT=$$PRTVSTS(DFN,IBYR)
+3 ;Ask user to Add or Edit Visit
+4 WRITE !!
+5 SET IBAE=$$GETMAINT
+6 IF IBAE=-1
GOTO LOOP
+7 ;
+8 IF IBAE="A"
DO ADDVST(DFN)
+9 IF IBAE="E"
DO EDITVST(IBLCT)
+10 ;
+11 DO PAUSE(1)
+12 ;
+13 IF IBQUIT=1
GOTO LOOP
+14 ; Clear temp global after work on the veteran is done.
+15 KILL ^TMP($JOB,"IBMHVM")
+16 GOTO MLOOP
+17 ;
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")=2023
+4 SET DIR(0)="F^4:4^K:X'?4N X"
+5 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
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(^IBMH(351.83,"B",IBDFN,IBI))
if 'IBI
QUIT
Begin DoDot:1
+7 SET IBD=$GET(^IBMH(351.83,IBI,0))
if 'IBD
QUIT
+8 SET IBSTAT=$PIECE(IBD,U,4)
+9 SET IBDT=$PIECE(IBD,U,3)
+10 ; Convert visit date to calendar year
SET IBVYR=$EXTRACT(IBDT,1,3)+1700
+11 IF IBYR'=IBVYR
QUIT
+12 SET IBC=IBC+1
+13 SET ^TMP($JOB,"IBMHVM","IBA",IBC)=IBDT
SET ^TMP($JOB,"IBMHVM","IBA","D",IBDT,IBC)=IBI_U_IBD
+14 QUIT
End DoDot:1
+15 ;
+16 ;Reorganize in date order for display
+17 SET (IBLDT,IBLCT)=0
FOR
SET IBLDT=$ORDER(^TMP($JOB,"IBMHVM","IBA","D",IBLDT))
if 'IBLDT
QUIT
Begin DoDot:1
+18 SET IBLDT1=0
FOR
SET IBLDT1=$ORDER(^TMP($JOB,"IBMHVM","IBA","D",IBLDT,IBLDT1))
if 'IBLDT1
QUIT
Begin DoDot:2
+19 SET IBLCT=IBLCT+1
+20 SET ^TMP($JOB,"IBMHVM","IBP",IBLCT)=$GET(^TMP($JOB,"IBMHVM","IBA","D",IBLDT,IBLDT1))
+21 QUIT
End DoDot:2
End DoDot:1
+22 ;
+23 WRITE @IOF
+24 SET IBPT=$$PT^IBEFUNC(IBDFN)
+25 WRITE !,"Mental Health Visits in "_IBYR_" for "_$PIECE(IBPT,U),!
+26 DO LINE("=",80)
+27 IF 'IBC
WRITE "No Mental Health Visits during this calendar year."
QUIT 0
+28 SET IBV=IBLCT\3
IF IBC#3
SET IBV=IBV+1
+29 FOR IBI=1:1:IBV
Begin DoDot:1
+30 if $DATA(IBQUIT)
DO CHKPAUSE
+31 SET IBN=IBI
+32 SET IBD=$GET(^TMP($JOB,"IBMHVM","IBP",IBN))
+33 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:"")
+34 SET IBN=IBI+IBV
SET IBD=$GET(^TMP($JOB,"IBMHVM","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:"")
+35 SET IBN=IBI+(2*IBV)
SET IBD=$GET(^TMP($JOB,"IBMHVM","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:"")
+36 QUIT
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 NEW X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
+2 ; Prompt Summary or Detail version
+3 SET DIR("A")="(A)dd a Mental Health Visit, (E)dit an existing Visit, or (Q)uit: "
+4 SET DIR(0)="SA^A:ADD;E:Edit;Q:Quit"
+5 SET DIR("?")="Select whether to Add a new Mental Health visit, Edit an Existing visit, or Quit."
+6 ;
+7 DO ^DIR
KILL DIR
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)="")
QUIT -1
+9 IF Y="Q"
QUIT -1
+10 QUIT Y
+11 ;
ADDVST(IBDFN) ; Add a new MH visit for the patient
+1 NEW IBVST,IBIEN,IBSTAT,IBCOMM,IBSITE,IBDUPFLG,IBOVRFLG,IBIND
+2 ;
+3 SET (IBIEN,IBVST,IBSTAT,IBCOMM)=""
SET IBDUPFLG=0
+4 ; retrieve the Billing Site value from the IB Site Parameter File. Store in IBSITE
DO SITE^IBAUTL
+5 SET IBVST=$$GETVST()
if IBVST=-1
QUIT
+6 IF $DATA(^TMP($JOB,"IBMHVM","IBA","D",IBVST))
SET IBDUPFLG=1
+7 SET IBIND=$$INDCHK^IBINUT1(IBVST,DFN)
+8 SET IBSTAT=$$GETSTAT(DFN,IBVST,IBIND,.IBOVRFLG)
if IBSTAT=-1
QUIT
+9 IF IBSTAT=2
SET IBIEN=$$GETBILL(DFN,IBVST)
IF 'IBIEN
WRITE !,"No Cleland-Dole eligible charge was found for this date."
QUIT
+10 if IBSTAT'=2
SET IBCOMM=$$GETCOMM(IBSTAT,IBOVRFLG)
+11 if IBCOMM=-1
QUIT
+12 SET IBOK=$$GETOK^IBECEA36(IBDUPFLG)
if IBOK'=1
QUIT
+13 DO ADDVST^IBECEAMH(IBDFN,IBVST,IBIEN,IBSTAT,IBCOMM,IBSITE)
+14 QUIT
+15 ;
EDITVST(IBLCT) ; Edit an existing MH visit for the patient
+1 NEW IBSTAT,IBVISIT,IBIEN,IBD,IBSITECD,IBSITENM,IBVSITE,IBVST,IBVSTIEN,IBOK,IBOVRFLG,IBIND,IBCOMM
+2 ; Ask user for visit to edit
+3 SET (IBSTAT,IBVSITE,IBOVRFLG)=""
+4 SET IBVISIT=$$GETVISIT(IBLCT)
+5 if IBVISIT=-1
QUIT
+6 ; Get the visit info
+7 SET IBD=$GET(^TMP($JOB,"IBMHVM","IBP",IBVISIT))
if IBD=""
QUIT
+8 SET IBVSTIEN=$PIECE(IBD,U)
SET IBVST=$PIECE(IBD,U,4)
SET IBIEN=$PIECE(IBD,U,9)
+9 ; Get the Site name and code
+10 IF $PIECE(IBD,U,3)'=""
Begin DoDot:1
+11 SET IBSITECD=$$GET1^DIQ(4,$PIECE(IBD,U,3)_",",99,"I")
+12 SET IBSITENM=$$GET1^DIQ(4,$PIECE(IBD,U,3)_",",.01,"E")
+13 SET IBVSITE=$EXTRACT(IBSITECD_"-"_IBSITENM,1,20)
+14 QUIT
End DoDot:1
+15 ; display the visit info
+16 WRITE !!,"Date of Visit",?16,"Station",?39,"Status",?51,"Bill No.",?64,"Reason"
+17 WRITE !,"-------------",?16,"-------",?39,"------",?51,"--------",?64,"------"
+18 WRITE !,$$FMTE^XLFDT($PIECE(IBD,U,4)),?16,IBVSITE,?39,$$GET1^DIQ(351.83,IBVSTIEN,.04)
+19 IF $PIECE(IBD,U,6)'=""
WRITE ?51,$PIECE(IBD,U,6)
+20 IF $PIECE(IBD,U,7)'=""
WRITE ?64,$EXTRACT($$GET1^DIQ(351.83,IBVSTIEN,.06),1,19)
+21 WRITE !!
+22 SET IBIND=$$INDCHK^IBINUT1(IBVST,DFN)
+23 ; Prompt for Status change
+24 SET IBSTAT=$$GETSTAT(DFN,IBVST,IBIND,.IBOVRFLG)
+25 if IBSTAT=-1
QUIT
+26 IF $$CHKDUP(IBSTAT,IBVSTIEN)
WRITE !!,"Visit can only be edited to a different status."
QUIT
+27 SET IBCOMM=0
IF IBSTAT=4
SET IBCOMM=$$GETCOMM(IBSTAT,IBOVRFLG)
if IBCOMM=3
SET IBSTAT=1
+28 ; Confirm with user with no Duplicate Visit flag.
+29 SET IBOK=$$GETOK^IBECEA36(0)
+30 if IBOK'=1
QUIT
+31 ; Save the changes.
+32 DO UPDVST^IBECEAMH(IBIEN,IBSTAT,IBVSTIEN)
+33 QUIT
+34 ;
+35 ;Ask the user for the type of work to do
GETVST() ;
+1 NEW X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
+2 NEW SDT
+3 SET SDT=$$GET1^DIQ(350.9,"1,",71.03,"I")
+4 SET DIR("A")="Visit Date: "
+5 SET DIR(0)="DA^"_SDT_":"_DT
+6 SET DIR("?")="The visit has to occur between "_$$FMTE^XLFDT(SDT,"2DZ")_" and Today."
+7 DO ^DIR
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)="")
QUIT -1
+9 QUIT Y
+10 ;
GETSTAT(IBDFN,IBVST,IBIND,IBOVRFLG) ;Ask the user for the Status of the Visit
+1 ;
+2 NEW X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT,IBRUR,IBSCSA,IBY
+3 ;
+4 SET IBOVRFLG=0
+5 IF IBAE="A"
IF IBIND
Begin DoDot:1
+6 WRITE !!,"Unable to add visit for patient covered by Indian Attestation exemption.",!
+7 QUIT
End DoDot:1
QUIT -1
+8 ;Add Prompt
+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."
+13 QUIT
End DoDot:1
+14 ;Edit Prompt
+15 IF IBAE="E"
Begin DoDot:1
+16 SET DIR("A")="(F)REE, (R)emoved, or (V)isit Only: "
+17 SET DIR(0)="SA^3:FREE;4:REMOVED;2:VISIT ONLY"
+18 SET DIR("?")="Select whether the visit was a FREE, REMOVED or VISIT ONLY."
+19 QUIT
End DoDot:1
+20 ;
+21 DO ^DIR
KILL DIR
+22 ;
+23 IF $DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)="")
QUIT -1
+24 SET IBY=Y
+25 ;
+26 ; If a free visit, check to see if there are already 3 or more visits. If so warn the user and exit.
+27 IF IBY=1
IF '$$NUMVSTCK^IBECEAMH(IBDFN,IBVST)
Begin DoDot:1
+28 WRITE !!,"Per the Cleland-Dole Act, this patient has already used their 3 free"
+29 WRITE !,"visits for the calendar year.",!
+30 QUIT
End DoDot:1
QUIT -1
+31 QUIT IBY
+32 ;
GETCOMM(IBSTAT,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.83
+3 ; 1 - FREE
+4 ; 2 - VISIT ONLY
+5 ; 4 - REMOVED
+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 FRM Override
IF IBSTAT=1
IF IBOVRFLG=1
QUIT 6
+12 ; Defaults to reason Cleland-Dole
IF IBSTAT=1
QUIT 2
+13 ; If the status is VISIT ONLY, auto populate the Reason with No Copay Required
+14 IF IBSTAT=2
QUIT 5
+15 ; Ask user for the REMOVED reason.
+16 SET DIR("A")="Reason for (E)ntered in Error or (D)uplicate Visit: "
+17 SET DIR(0)="SA^3:Entered in Error;4:Duplicate Visit"
+18 SET DIR("?")="Select a reason to associate with the REMOVED visit status."
+19 ;
+20 DO ^DIR
KILL DIR
+21 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT -1
+22 QUIT Y
+23 ;
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
+5 ;
GETBILL(IBDFN,IBVSTDT) ; get bill # from file 350
+1 ;
+2 ; IBDFN - patient's DFN
+3 ; IBVSTDT - visit date
+4 ;
+5 ; returns file 350 ien, or 0 if no file 350 entry was found.
+6 ;
+7 NEW IBENC,IBIEN,IBOK,IBSTAT,N0,STOP,RES,Z
+8 SET (RES,STOP)=0
+9 SET IBIEN=""
FOR
SET IBIEN=$ORDER(^IB("ACHDT",IBDFN,IBVSTDT,IBIEN))
if 'IBIEN!STOP
QUIT
Begin DoDot:1
+10 SET IBSTAT=$$GET1^DIQ(350,IBIEN,.05)
IF IBSTAT="CANCELLED"
QUIT
+11 SET N0=$GET(^IB(IBIEN,0))
+12 SET IBOK=$$ISCDCANC^IBECEAMH(IBIEN)
+13 IF 'IBOK
SET Z=$PIECE($PIECE(N0,U,4),";")
if $PIECE(Z,"
QUIT
SET IBENC=$PIECE(Z,":",2)
SET IBOK=$$OECHK^IBECEAMH(IBENC,IBVSTDT)
+14 ; not Cleland-Dole eligible
IF 'IBOK
QUIT
+15 SET RES=IBIEN
SET STOP=1
+16 QUIT
End DoDot:1
+17 QUIT RES
+18 ;
CHKDUP(IBSTAT,IBVSTIEN) ; check for duplicate visit status
+1 ;
+2 ; IBSTAT - new visit status (from $$GETSTAT() function)
+3 ; IBVSTIEN - file 351.83 ien
+4 ;
+5 ; returns 1 if new status is the same as existing one, 0 otherwise
+6 ;
+7 NEW TMP
+8 ; convert $$GETSTAT() result to appropriate code for field 351.83/.04
SET TMP=$SELECT(IBSTAT=3:1,IBSTAT=4:3,1:4)
+9 IF $$GET1^DIQ(351.83,IBVSTIEN,.04,"I")=TMP
QUIT 1
+10 QUIT 0
