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

IBMHVM.m

Go to the documentation of this file. 
  1. IBMHVM ;EDE/YMG - Mental Health Visit Maintenance; 07/06/2023
  1.  ;;2.0;INTEGRATED BILLING;**784,779**;21-MAR-94;Build 7
  1.  ;; Per VHA Directive 6402, this routine should not be modified
  1.  ;
  1.  ; This routine is used to perform the Mental Health Visit Tracking
  1.  ; database Maintenance.
  1.  ;
  1.  Q
  1.  ;
  1. EN ; entry point
  1.  N DIC,X,Y,DFN,DTOUT,DUOUT,DIRUT,DIROUT,%,DIR,IBYR,IBLCT,IBAE,IBQUIT
  1.  ;
  1.  S IBQUIT=0
  1. LOOP K DIC,X,Y,DFN,IBLTCX,VADP,IBLCT
  1.  K ^TMP($J,"IBMHVM")
  1.  ;
  1.  ;Ask for the patient
  1.  N DPTNOFZY S DPTNOFZY=1  ;Suppress PATIENT file fuzzy lookups
  1.  S DIC="^DPT(",DIC(0)="AEMNQ" W ! D ^DIC G:Y<1 EX
  1.  S DFN=+Y D DEM^VADPT
  1.  ;
  1.  S IBYR=$$ASKDT("Enter Year")
  1.  G:IBYR=-1 LOOP
  1.  ;
  1. MLOOP ; Entry/Loop tag to allow user to stay with the defined maintenance utility.
  1.  ;
  1.  S IBLCT=$$PRTVSTS(DFN,IBYR)
  1.  ;Ask user to Add or Edit Visit
  1.  W !!
  1.  S IBAE=$$GETMAINT
  1.  I IBAE=-1 G LOOP
  1.  ;
  1.  I IBAE="A" D ADDVST(DFN)
  1.  I IBAE="E" D EDITVST(IBLCT)
  1.  ;
  1.  D PAUSE(1)
  1.  ;
  1.  I IBQUIT=1 G LOOP
  1.  ; Clear temp global after work on the veteran is done.
  1.  K ^TMP($J,"IBMHVM")
  1.  G MLOOP
  1.  ;
  1. EX ;
  1.  D KVAR^VADPT
  1.  ;
  1.  Q
  1.  ;
  1. ASKDT(IBPRMT) ;Date input
  1.  N DIR,Y,X,DIROUT,DIRUT
  1.  I $G(IBPRMT)'="" S DIR("A")=IBPRMT
  1.  S DIR("B")=2023
  1.  S DIR(0)="F^4:4^K:X'?4N X"
  1.  D ^DIR I $D(DIRUT)!$D(DIROUT) Q -1
  1.  W " ",Y
  1.  Q Y
  1.  ;
  1. PRTVSTS(IBDFN,IBYR) ; Get the list of visits for the calendar year
  1.  ;
  1.  N IBZ,IBV,IBC,IBI,IBN,IBD,IBSTAT,IBDT,IBLDT,IBLDT1,IBPT,IBQUIT,IBVYR
  1.  ;
  1.  S IBC=0 ; Counter of Visits
  1.  ; Collect the list of visits
  1.  S IBI=0 F  S IBI=$O(^IBMH(351.83,"B",IBDFN,IBI)) Q:'IBI  D
  1.  .S IBD=$G(^IBMH(351.83,IBI,0)) Q:'IBD
  1.  .S IBSTAT=$P(IBD,U,4)
  1.  .S IBDT=$P(IBD,U,3)
  1.  .S IBVYR=$E(IBDT,1,3)+1700    ; Convert visit date to calendar year
  1.  .I IBYR'=IBVYR Q
  1.  .S IBC=IBC+1
  1.  .S ^TMP($J,"IBMHVM","IBA",IBC)=IBDT,^TMP($J,"IBMHVM","IBA","D",IBDT,IBC)=IBI_U_IBD
  1.  .Q
  1.  ;
  1.  ;Reorganize in date order for display
  1.  S (IBLDT,IBLCT)=0 F  S IBLDT=$O(^TMP($J,"IBMHVM","IBA","D",IBLDT)) Q:'IBLDT  D
  1.  .S IBLDT1=0 F  S IBLDT1=$O(^TMP($J,"IBMHVM","IBA","D",IBLDT,IBLDT1)) Q:'IBLDT1  D
  1.  ..S IBLCT=IBLCT+1
  1.  ..S ^TMP($J,"IBMHVM","IBP",IBLCT)=$G(^TMP($J,"IBMHVM","IBA","D",IBLDT,IBLDT1))
  1.  ..Q
  1.  ;
  1.  W @IOF
  1.  S IBPT=$$PT^IBEFUNC(IBDFN)
  1.  W !,"Mental Health Visits in "_IBYR_" for "_$P(IBPT,U),!
  1.  D LINE("=",80)
  1.  I 'IBC W "No Mental Health Visits during this calendar year." Q 0
  1.  S IBV=IBLCT\3 I IBC#3 S IBV=IBV+1
  1.  F IBI=1:1:IBV D  Q:$G(IBQUIT)
  1.  .D:$D(IBQUIT) CHKPAUSE
  1.  .S IBN=IBI
  1.  .S IBD=$G(^TMP($J,"IBMHVM","IBP",IBN))
  1.  .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:"")
  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:"")
  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:"")
  1.  .Q
  1.  Q IBLCT
  1.  ;
  1. PAUSE(IBEND) Q:'$$SCR()  ;Screen only
  1.  N IBJ,DIR,DIRUT,DTOUT,DUOUT,DIROUT,Y,IOSL2
  1.  S IBQUIT=0
  1.  Q:$E(IOST,1,2)'["C-"
  1.  S IOSL2=$S(IOSL>24:24,1:IOSL)
  1.  F IBJ=$Y:1:(IOSL2-4) W !
  1.  I $G(IBEND) S DIR("A")="Enter RETURN to continue or '^' to exit."
  1.  S DIR(0)="E"
  1.  D ^DIR
  1.  K DIR
  1.  I $G(DUOUT) S IBQUIT=1
  1.  I $G(IBEND) W @IOF
  1.  Q
  1.  ;
  1. CHKPAUSE ;Check pause
  1.  I $Y>(IOSL-5) D PAUSE Q:IBQUIT  W @IOF D LINE("-",80) W !
  1.  Q
  1.  ;
  1. SCR() Q $E(IOST,1,2)="C-" ; Screen
  1.  ;
  1.  ; Draw a line, of characters IBC, length IBN
  1. LINE(IBC,IBN) N IBL
  1.  I $L($G(IBC))'=1 S IBC="="
  1.  I +$G(IBN)=0 S IBN=80
  1.  S $P(IBL,IBC,IBN+1)=""
  1.  W IBL
  1.  Q
  1.  ;
  1.  ; Fotmatting row labels
  1. FRM(IBLBL,IBCUT) ;
  1.  I $G(IBCUT,1) S IBLBL=$E(IBLBL,1,26)
  1.  Q "  "_IBLBL_": "  ;;;$J("",26-$L(IBLBL))_":  "
  1.  ;
  1.  ;Ask the user for the type of work to do
  1. GETMAINT() ;
  1.  N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
  1.  ; Prompt Summary or Detail version
  1.  S DIR("A")="(A)dd a Mental Health Visit, (E)dit an existing Visit, or (Q)uit: "
  1.  S DIR(0)="SA^A:ADD;E:Edit;Q:Quit"
  1.  S DIR("?")="Select whether to Add a new Mental Health visit, Edit an Existing visit, or Quit."
  1.  ;
  1.  D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT)!($G(Y)="")  Q -1
  1.  I Y="Q" Q -1
  1.  Q Y
  1.  ;
  1. ADDVST(IBDFN) ; Add a new MH visit for the patient
  1.  N IBVST,IBIEN,IBSTAT,IBCOMM,IBSITE,IBDUPFLG,IBOVRFLG,IBIND
  1.  ;
  1.  S (IBIEN,IBVST,IBSTAT,IBCOMM)="",IBDUPFLG=0
  1.  D SITE^IBAUTL   ; retrieve the Billing Site value from the IB Site Parameter File.  Store in IBSITE
  1.  S IBVST=$$GETVST() Q:IBVST=-1
  1.  I $D(^TMP($J,"IBMHVM","IBA","D",IBVST)) S IBDUPFLG=1
  1.  S IBIND=$$INDCHK^IBINUT1(IBVST,DFN)
  1.  S IBSTAT=$$GETSTAT(DFN,IBVST,IBIND,.IBOVRFLG) Q:IBSTAT=-1
  1.  I IBSTAT=2 S IBIEN=$$GETBILL(DFN,IBVST) I 'IBIEN W !,"No Cleland-Dole eligible charge was found for this date." Q
  1.  S:IBSTAT'=2 IBCOMM=$$GETCOMM(IBSTAT,IBOVRFLG)
  1.  Q:IBCOMM=-1
  1.  S IBOK=$$GETOK^IBECEA36(IBDUPFLG) Q:IBOK'=1
  1.  D ADDVST^IBECEAMH(IBDFN,IBVST,IBIEN,IBSTAT,IBCOMM,IBSITE)
  1.  Q
  1.  ;
  1. EDITVST(IBLCT) ; Edit an existing MH visit for the patient
  1.  N IBSTAT,IBVISIT,IBIEN,IBD,IBSITECD,IBSITENM,IBVSITE,IBVST,IBVSTIEN,IBOK,IBOVRFLG,IBIND,IBCOMM,IBUID
  1.  ; Ask user for visit to edit
  1.  S (IBSTAT,IBVSITE,IBOVRFLG)=""
  1.  S IBVISIT=$$GETVISIT(IBLCT)
  1.  Q:IBVISIT=-1
  1.  ; Get the visit info
  1.  S IBD=$G(^TMP($J,"IBMHVM","IBP",IBVISIT)) Q:IBD=""
  1.  S IBVSTIEN=$P(IBD,U),IBVST=$P(IBD,U,4),IBIEN=$P(IBD,U,9)
  1.  ;IB*2.0*801 - Prevent edits on visits from other sites
  1.  ;
  1.  ;Check to see if visit info is from another site, if so, warn the user and quit.
  1.  S IBUID=$P($G(^IBMH(351.83,IBVSTIEN,0)),U,7)
  1.  I IBUID["_" D  Q -1
  1.  . W !!,"Unable to edit this visit.  The visit data is from another VAMC."
  1.  . W !,"Please select another visit to edit."
  1.  ;END IB 801
  1.  ; Get the Site name and code
  1.  I $P(IBD,U,3)'="" D
  1.  .S IBSITECD=$$GET1^DIQ(4,$P(IBD,U,3)_",",99,"I")
  1.  .S IBSITENM=$$GET1^DIQ(4,$P(IBD,U,3)_",",.01,"E")
  1.  .S IBVSITE=$E(IBSITECD_"-"_IBSITENM,1,20)
  1.  .Q
  1.  ; display the visit info
  1.  W !!,"Date of Visit",?16,"Station",?39,"Status",?51,"Bill No.",?64,"Reason"
  1.  W !,"-------------",?16,"-------",?39,"------",?51,"--------",?64,"------"
  1.  W !,$$FMTE^XLFDT($P(IBD,U,4)),?16,IBVSITE,?39,$$GET1^DIQ(351.83,IBVSTIEN,.04)
  1.  I $P(IBD,U,6)'="" W ?51,$P(IBD,U,6)
  1.  I $P(IBD,U,7)'=""  W ?64,$E($$GET1^DIQ(351.83,IBVSTIEN,.06),1,19)
  1.  W !!
  1.  S IBIND=$$INDCHK^IBINUT1(IBVST,DFN)
  1.  ; Prompt for Status change
  1.  S IBSTAT=$$GETSTAT(DFN,IBVST,IBIND,.IBOVRFLG)
  1.  Q:IBSTAT=-1
  1.  I $$CHKDUP(IBSTAT,IBVSTIEN) W !!,"Visit can only be edited to a different status." Q
  1.  S IBCOMM=0 I IBSTAT=4 S IBCOMM=$$GETCOMM(IBSTAT,IBOVRFLG) S:IBCOMM=3 IBSTAT=1
  1.  ; Confirm with user with no Duplicate Visit flag.
  1.  S IBOK=$$GETOK^IBECEA36(0)
  1.  Q:IBOK'=1
  1.  ; Save the changes.
  1.  D UPDVST^IBECEAMH(IBIEN,IBSTAT,IBVSTIEN)
  1.  Q
  1.  ;
  1.  ;Ask the user for the type of work to do
  1. GETVST() ;
  1.  N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
  1.  N SDT
  1.  S SDT=$$GET1^DIQ(350.9,"1,",71.03,"I")
  1.  S DIR("A")="Visit Date: "
  1.  S DIR(0)="DA^"_SDT_":"_DT
  1.  S DIR("?")="The visit has to occur between "_$$FMTE^XLFDT(SDT,"2DZ")_" and Today."
  1.  D ^DIR
  1.  I $D(DTOUT)!$D(DUOUT)!($G(Y)="")  Q -1
  1.  Q Y
  1.  ;
  1. GETSTAT(IBDFN,IBVST,IBIND,IBOVRFLG) ;Ask the user for the Status of the Visit
  1.  ;
  1.  N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT,IBRUR,IBSCSA,IBY
  1.  ;
  1.  S IBOVRFLG=0
  1.  I IBAE="A",IBIND D  Q -1
  1.  .W !!,"Unable to add visit for patient covered by Indian Attestation exemption.",!
  1.  .Q
  1.  ;Add Prompt
  1.  I IBAE="A" D
  1.  .S DIR("A")="(F)REE, (B)ILLED, or (V)isit Only: "
  1.  .S DIR(0)="SA^1:FREE;2:BILLED;4:VISIT ONLY"
  1.  .S DIR("?")="Select whether the visit was a FREE, BILLED, or VISIT ONLY."
  1.  .Q
  1.  ;Edit Prompt
  1.  I IBAE="E" D
  1.  .S DIR("A")="(F)REE, (R)emoved, or (V)isit Only: "
  1.  .S DIR(0)="SA^3:FREE;4:REMOVED;2:VISIT ONLY"
  1.  .S DIR("?")="Select whether the visit was a FREE, REMOVED or VISIT ONLY."
  1.  .Q
  1.  ;
  1.  D ^DIR K DIR
  1.  ;
  1.  I $D(DTOUT)!$D(DUOUT)!($G(Y)="")  Q -1
  1.  S IBY=Y
  1.  ;
  1.  ; If a free visit, check to see if there are already 3 or more visits.  If so warn the user and exit.
  1.  I IBY=1,'$$NUMVSTCK^IBECEAMH(IBDFN,IBVST) D  Q -1
  1.  .W !!,"Per the Cleland-Dole Act, this patient has already used their 3 free"
  1.  .W !,"visits for the calendar year.",!
  1.  .Q
  1.  Q IBY
  1.  ;
  1. GETCOMM(IBSTAT,IBOVRFLG) ; Ask the user for the status reason (or default it if Status is FREE)
  1.  ;
  1.  ;Input: IBSTAT - The visit status (from code set in .06 field in file 351.83
  1.  ;                1 - FREE
  1.  ;                2 - VISIT ONLY
  1.  ;                4 - REMOVED
  1.  ;
  1.  N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
  1.  ;
  1.  ;
  1.  ; If the status is to be FREE, auto populate the Reason based on Priority Group
  1.  I IBSTAT=1,IBOVRFLG=1 Q 6  ; Defaults to reason FRM Override
  1.  I IBSTAT=1 Q 2             ; Defaults to reason Cleland-Dole
  1.  ; If the status is VISIT ONLY, auto populate the Reason with No Copay Required
  1.  I IBSTAT=2 Q 5
  1.  ; Ask user for the REMOVED reason.
  1.  S DIR("A")="Reason for (E)ntered in Error or (D)uplicate Visit: "
  1.  S DIR(0)="SA^3:Entered in Error;4:Duplicate Visit"
  1.  S DIR("?")="Select a reason to associate with the REMOVED visit status."
  1.  ;
  1.  D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT)  Q -1
  1.  Q Y
  1.  ;
  1. GETVISIT(IBLCT) ; Get the IEN for visit to be edited.
  1.  ;
  1.  S DIR("A")="Enter Visit Number: "
  1.  S DIR(0)="NA^1:"_IBLCT_"^"
  1.  S DIR("?")="Enter the Visit to edit from the list above"
  1.  D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT)!(Y<1)  Q -1
  1.  ;
  1.  Q +Y
  1.  ;
  1. DISPCHG(IBSTAT,IBBILL,IBREAS) ;Redisplay the changes requested
  1.  ;
  1.  W "The following updates will be made to this visit:"
  1.  W !!
  1.  Q
  1.  ;
  1. GETBILL(IBDFN,IBVSTDT) ; get bill # from file 350
  1.  ;
  1.  ; IBDFN - patient's DFN
  1.  ; IBVSTDT - visit date
  1.  ;
  1.  ; returns file 350 ien, or 0 if no file 350 entry was found.
  1.  ;
  1.  N IBENC,IBIEN,IBOK,IBSTAT,N0,STOP,RES,Z
  1.  S (RES,STOP)=0
  1.  S IBIEN="" F  S IBIEN=$O(^IB("ACHDT",IBDFN,IBVSTDT,IBIEN)) Q:'IBIEN!STOP  D
  1.  .S IBSTAT=$$GET1^DIQ(350,IBIEN,.05) I IBSTAT="CANCELLED" Q
  1.  .S N0=$G(^IB(IBIEN,0))
  1.  .S IBOK=$$ISCDCANC^IBECEAMH(IBIEN)
  1.  .I 'IBOK S Z=$P($P(N0,U,4),";") Q:$P(Z,":")'="409.68"  S IBENC=$P(Z,":",2),IBOK=$$OECHK^IBECEAMH(IBENC,IBVSTDT)
  1.  .I 'IBOK Q  ; not Cleland-Dole eligible
  1.  .S RES=IBIEN,STOP=1
  1.  .Q
  1.  Q RES
  1.  ;
  1. CHKDUP(IBSTAT,IBVSTIEN) ; check for duplicate visit status
  1.  ;
  1.  ; IBSTAT - new visit status (from $$GETSTAT() function)
  1.  ; IBVSTIEN - file 351.83 ien
  1.  ;
  1.  ; returns 1 if new status is the same as existing one, 0 otherwise
  1.  ;
  1.  N TMP
  1.  S TMP=$S(IBSTAT=3:1,IBSTAT=4:3,1:4) ; convert $$GETSTAT() result to appropriate code for field 351.83/.04
  1.  I $$GET1^DIQ(351.83,IBVSTIEN,.04,"I")=TMP Q 1
  1.  Q 0