IBOHLS ;ALB/JWS,BAA - IB HELD CHARGES LIST MANAGER ;08-SEP-2015
;;2.0;INTEGRATED BILLING;**554**;21-MAR-94;Build 81
;Per VA Directive 6402, this routine should not be modified.
;
EN ; -- main entry point for HELD CHARGES LIST
; add code to do filters here
N FILTERS
I '$$FILTER(.FILTERS) Q
;
; code to do sort
D SORT
;
D EN^VALM("IBOH HELD CHARGES LIST")
D ^%ZISC
Q
;
HDR ; -- header code
;
N BDATE,EDATE,INSTS,PATS,IINS,OLDH
N VAL,T1,D
S BDATE=$P(FILTERS(0),U,1),EDATE=$P(FILTERS(0),U,2)
S INSTS=$P(FILTERS(0),U,3),PATS=$P(FILTERS(0),U,4)
S IINS=FILTERS(3)
;
I 'INSTS S T1="All Divisions Selected"
I INSTS D
. S T1="Divisions : "
. S D=0 F S D=$O(FILTERS(1,D)) Q:D="" S T1=T1_$S(T1="Divisions : ":"",1:", ")_$P(FILTERS(1,D),"-",2)
S VALMHDR(1)=T1
S VALMSG="* No Associated Clinic"
Q
;
INIT ; -- init variables and list array
; input - none
; output ^TMP($J,"IBOHLS")
N BDATE,EDATE,INSTS,PATS,IINS,OLDH
S BDATE=$P(FILTERS(0),U,1),EDATE=$P(FILTERS(0),U,2)
S INSTS=$P(FILTERS(0),U,3),PATS=$P(FILTERS(0),U,4)
S IINS=FILTERS(3)
D BLD
Q
;
SORT ; get the data
N BDATE,EDATE,INSTS,PATS,IINS,OLDH
S BDATE=$P(FILTERS(0),U,1),EDATE=$P(FILTERS(0),U,2)
S INSTS=$P(FILTERS(0),U,3),PATS=$P(FILTERS(0),U,4)
S IINS=FILTERS(3),CNT=0
S ^TMP($J,"IBOHLSF")=FILTERS(0)
K ^TMP($J,"IBOHLS")
K ^TMP($J,"IBHOLD")
K ^TMP($J,"IBOHLS INS")
;
D SORT^IBOHLS1
Q
;
EXPAND ; -- expand code
D FULL^VALM1
N I,J,IBXX,VALMY,ECNT,PNAME,DFN,IBHLD0,REC,IBIEN,LST,CLINIC
D EN^VALM2($G(XQORNOD(0)))
I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D ;W !,"Entry ",X,"Selected" D
. K ^TMP($J,"IBOHLE")
. S REC=$G(^TMP($J,"IBOHLSX",IBXX))
. S DFN=$P(REC,U,1),PNAME=$P(REC,U,2),ECNT=$P(REC,U,3)
. S IBIEN=$P(^TMP($J,"IBOHLS",PNAME,ECNT,"IBND"),U,3)
. S LST=$P(^TMP($J,"IBOHLS",PNAME,ECNT,"IBND"),U,6)
. S CLINIC=$P(^TMP($J,"IBOHLS",PNAME,ECNT,"IBND"),U,8)
. Q:IBIEN=""
. S ^TMP($J,"IBOHLSE")=DFN_U_ECNT_U_PNAME_U_IBIEN_U_LST_U_CLINIC
. D EN^VALM("IBOH HELD CHARGES EXPAND")
. Q
D BLD
S VALMBCK="R"
Q
;
BLD ; build data to display
; build display
K ^TMP($J,"IBOHLSX")
K ^TMP("VALMAR",$J)
N FIRST,VCNT,CNT,NAME,BCNT,RNB,RX,CLINIC,INST,DNAME,FLAG
S VALMCNT=0
S (CNT,VCNT)=0,NAME=""
F S NAME=$O(^TMP($J,"IBOHLS",NAME)) Q:NAME="" D
. S FIRST=1
. F S CNT=$O(^TMP($J,"IBOHLS",NAME,CNT)) Q:CNT="" D
.. S FLAG="",FLAG=$P(^TMP($J,"IBOHLS",NAME,CNT,"IBND"),U,7)
.. S INST="",INST=$P(^TMP($J,"IBOHLS",NAME,CNT,"IBND"),U,6)
.. S CLINIC="",CLINIC=$P(^TMP($J,"IBOHLS",NAME,CNT,"IBND"),U,8)
.. S VCNT=VCNT+1
.. S LINE=$$SETL("",VCNT,"",1,5) ;line#
.. S XX=^TMP($J,"IBOHLS",NAME,CNT)
.. S DFN=$P(^TMP($J,"IBOHLS",NAME,CNT,"IBND"),U,1)
.. S DNAME=FLAG_$P(XX,U)
.. S LINE=$$SETL(LINE,DNAME,"",6,21)
.. S LINE=$$SETL(LINE,$P(XX,U,2),"",28,6)
.. S LINE=$$SETL(LINE,$P(XX,U,3),"",37,6)
.. S LINE=$$SETL(LINE,$$FMTE^XLFDT($P(XX,U,4),"2DZ"),"",44,8)
.. S LINE=$$SETL(LINE,$$FMTE^XLFDT($P(XX,U,5),"2DZ"),"",54,8)
.. S LINE=$$SETL(LINE,$P(XX,U,6),"",64,5)
.. S LINE=$$SETL(LINE,$J($P(XX,U,7),8,2),"",72,8)
.. S VALMCNT=VALMCNT+1
.. D SET^VALM10(VALMCNT,LINE,VCNT)
.. S LINE=$$SETL("","Division: "_INST_" - "_CLINIC,"",6,60)
.. S VALMCNT=VALMCNT+1
.. D SET^VALM10(VALMCNT,LINE,VCNT)
.. S ^TMP($J,"IBOHLSX",VCNT)=DFN_U_NAME_U_CNT_U_INST_U_FLAG_U_CLINIC
.. I $D(^TMP($J,"IBOHLS",NAME,CNT,1)) D
... S RX=^TMP($J,"IBOHLS",NAME,CNT,1),RX="Rx#:"_RX
... S LINE=$$SETL("",RX,"",37,20)
... S VALMCNT=VALMCNT+1
... D SET^VALM10(VALMCNT,LINE,VCNT)
.. I $D(^TMP($J,"IBOHLS",NAME,CNT,2)) D
... S BCNT=0 F S BCNT=$O(^TMP($J,"IBOHLS",NAME,CNT,2,BCNT)) Q:BCNT="" D
.... S XX=^TMP($J,"IBOHLS",NAME,CNT,2,BCNT)
.... S LINE=$$SETL("","Bill: ","",6,6)
.... S LINE=$$SETL(LINE,$P(XX,U),"",14,10)
.... S LINE=$$SETL(LINE,$P(XX,U,2),"",26,10)
.... S LINE=$$SETL(LINE,$$FMTE^XLFDT($P(XX,U,3),"2DZ"),"",38,10)
.... S LINE=$$SETL(LINE,$$FMTE^XLFDT($P(XX,U,4),"2DZ"),"",50,10)
.... S LINE=$$SETL(LINE,$P(XX,U,5),"",62,4)
.... S LINE=$$SETL(LINE,$J($P(XX,U,6),8,2),"",68,10)
.... S VALMCNT=VALMCNT+1
.... D SET^VALM10(VALMCNT,LINE,VCNT)
.... S RNB=$P(XX,U,7)
.... I RNB'="" D
..... S LINE=$$SETL("","RNB: ","",6,6)
..... S LINE=$$SETL(LINE,RNB,"",14,60)
..... S VALMCNT=VALMCNT+1
..... D SET^VALM10(VALMCNT,LINE,VCNT)
.. I $D(^TMP($J,"IBOHLS INS",NAME)),FIRST D ; IF DISPLAYING INSURANCE INFORMATION
... S FIRST=0
... N ZZ,ZZ1,ZZ2
... S LINE=$$SETL("","Insurance","",6,9)
... S LINE=$$SETL(LINE,"Subscriber","",24,10)
... S LINE=$$SETL(LINE,"Group","",42,5)
... S LINE=$$SETL(LINE,"Eff Dt","",58,6)
... S LINE=$$SETL(LINE,"Exp Dt","",70,6)
... S VALMCNT=VALMCNT+1
... D SET^VALM10(VALMCNT,LINE,VCNT)
... S VALMCNT=VALMCNT+1
... S $P(ZZ2,"-",78)=""
... S LINE=$$SETL("",ZZ2,"",6,78)
... D SET^VALM10(VALMCNT,LINE,VCNT)
... S ZZ=0 F S ZZ=$O(^TMP($J,"IBOHLS INS",NAME,ZZ)) Q:ZZ="" D
.... S ZZ1=^TMP($J,"IBOHLS INS",NAME,ZZ)
.... S LINE=$$SETL("",$P(ZZ1,U),"",6,15)
.... S LINE=$$SETL(LINE,$P(ZZ1,U,2),"",24,15)
.... S LINE=$$SETL(LINE,$P(ZZ1,U,3),"",42,14)
.... S LINE=$$SETL(LINE,$$FMTE^XLFDT($P(ZZ1,U,4),"2DZ"),"",58,10)
.... S LINE=$$SETL(LINE,$$FMTE^XLFDT($P(ZZ1,U,5),"2DZ"),"",70,10)
.... S VALMCNT=VALMCNT+1
.... D SET^VALM10(VALMCNT,LINE,VCNT)
.... I '$O(^TMP($J,"IBOHLS INS",NAME,ZZ,0)) Q
.... S LINE=$$SETL("","Plan Coverage Eff. Date Covered? Limit Comments","",10,60)
.... S VALMCNT=VALMCNT+1
.... D SET^VALM10(VALMCNT,LINE,VCNT)
.... S ZZ2=0 F S ZZ2=$O(^TMP($J,"IBOHLS INS",NAME,ZZ,ZZ2)) Q:ZZ2="" D
..... S ZZ1=^TMP($J,"IBOHLS INS",NAME,ZZ,ZZ2)
..... S LINE=$$SETL("",$P(ZZ1,U),"",10,15)
..... S LINE=$$SETL(LINE,$P(ZZ1,U,2),"",27,8)
..... S LINE=$$SETL(LINE,$P(ZZ1,U,3),"",40,12)
..... S LINE=$$SETL(LINE,$P(ZZ1,U,4),"",55,25)
..... S VALMCNT=VALMCNT+1
..... D SET^VALM10(VALMCNT,LINE,VCNT)
Q
;
SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
; of the worklist
; Input: LINE - Current line being created
; DATA - Information to be added to the end of the current line
; LABEL - Label to describe the information being added
; COL - Column position in line to add information add
; LNG - Maximum length of data information to include on the line
; Returns: Line updated with added information
S LINE=LINE_$J("",(COL-$L(LABEL)-$L(LINE)))_LABEL_$E(DATA,1,LNG)
Q LINE
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP($J,"IBOHLSF")
K ^TMP($J,"IBOHLS")
K ^TMP($J,"IBHOLD")
K ^TMP($J,"IBOHLS INS")
;
D CLEAR^VALM1,CLEAN^VALM10
D ^%ZISC
Q
;
FILTER(FILTERS) ; filter display
; Sets an array of filters to determine which entris to include in display
; Input: None
; Output:
; Returns: 0 if the user entered '^' or timed out, 1 otherwise
; FILTERS(0) = from date ^ to date ^ 0 (all) 1 (selected) institutions ^ 0 (all) 1 (selected) patients
; FILTERS(1,inst ien) = ""
; FILTERS(2,pat ien) = ""
; FILTERS(3) = 0 (NO) 1 (YES) to include insurance information
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XX,Y,IBDATES
K FILTERS
; get date range
S IBDATES="Date of Service",IBDATES=$$FMDATES(IBDATES) I IBDATES=0 Q 0
S FILTERS(0)=IBDATES
;
; Site (Division) filter
W !
D PSDR^IBODIV
D CHKFILT
;
; Patient filter
S DIR(0)="S",DIR("A")="Select(A)ll or (S)elected Patient(s):",DIR("B")="All"
S DIR("?",1)="Enter 'A' to not filter by Patient."
S DIR("?")="Enter 'S' to view entries for selected Patients."
S $P(DIR(0),U,2)="A:All Patients;S:Selected Patients"
W ! D ^DIR K DIR
I $G(DIRUT) Q 0
S X=$$UP^XLFSTR(X)
S $P(FILTERS(0),U,4)=$S(Y="A":0,1:1)
; Set Patient / Veteran filter
I $P(FILTERS(0),U,4)=1 D ASKPAT(.FILTERS)
;
S DIR(0)="Y",DIR("A")="Include Insurance information on the Held Charges list",DIR("B")="NO"
S DIR("?",1)=" Enter: 'Y' - to include patient insurance information on the Held Charges list"
S DIR("?",2)=" 'N' - to exclude patient insurance information on the Held Charges list"
S DIR("?",3)=" '^' - to exit this option"
D ^DIR K DIR
I $G(DIRUT) Q 0
S FILTERS(3)=+Y
D SHOWFILT(.FILTERS)
I X="^" Q 0
Q 1
;
FMDATES(PROMPT) ; ask for date range
N %DT,X,Y,DT1,DT2,IB0,IB1,IB2
S DIR(0)="S",DIR("A")="Select(A)ll or (S)elected Date(s):",DIR("B")="All"
S DIR("?",1)="Enter 'A' to view all Dates."
S DIR("?")="Enter 'S' to view entries for selected Dates."
S $P(DIR(0),U,2)="A:All Dates;S:Selected Dates"
W ! D ^DIR K DIR
I X="^" Q 0
I $G(DIRUT) Q 0
I $E(Y)="A" S DT1=0_U_DT G FMDQ
S DT1="",IB1="Start with date entered: ",IB2="Go to date entered: "
I $G(PROMPT)'="" S IB1="Start with "_PROMPT_": ",IB2="Go to "_PROMPT_": "
S %DT="AEX",%DT("A")=IB1 D ^%DT K %DT I Y<0!($P(Y,".",1)'?7N) G FMDQ
S (%DT(0),DT2)=$P(Y,".",1) I DT2'>DT S %DT("B")="Today"
S %DT="AEX",%DT("A")=IB2 D ^%DT K %DT I Y<0!($P(Y,".",1)'?7N) G FMDQ
S DT1=DT2_U_$P(Y,".",1)
FMDQ Q DT1
;
;
ASKPAT(FILTERS) ; Sets a list of patients
; the HCSR Worklist
; Input: FILTERS - Current Array of filter settings
; Output: FILTERS - Updated Array of filter settings
N CLINS,DIC,DIR,DIRUT,IBDIVS,DUOUT,FIRST,IBIENS,IBIENS2,IEN,N,NM,NODE,WARDS,X,XX,Y
S DIC(0)="AEQMN",DIC="^DPT(",FIRST=1
F D Q:+IEN<1
. D ONEPAT(.DIC,.IEN,.FIRST) ; One patient
. Q:+IEN<1
. S IBIENS($P(IEN,U,2))=$P(IEN,U,1)
. S IBIENS2($P(IEN,U,1))=$P(IEN,U,2)
I '$D(IBIENS) S $P(FILTERS(0),U,4)=0 Q
;
; Set the filter node responses in alphabetical order
S XX=""
F D Q:XX=""
. S XX=$O(IBIENS(XX))
. Q:XX=""
. S N=IBIENS(XX)
. S FILTERS(2,N)=""
. ;S FILTERS(2)=$S($G(FILTERS(2))'="":FILTERS(2)_U_N,1:N)
Q
;
ONEPAT(DIC,IEN,FIRST) ; Prompts the user for a clinic or ward
; Input: DIC - Variable/Array of settings needed for ^DIC call
; FIRST - Set to 1 initially and then 0 for subsequent calls
; Output: FIRST - Set to 0
; IEN - IEN of the selected Ward or clinic Entry
; null of no selection was made
N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
S DIC("A")=$S(FIRST:"Select Patient: ",1:"Select Another Patient: ")
D ^DIC
S FIRST=0,IEN=Y
S DFN=+Y
Q
;
SHOWFILT(FILTERS) ;EP
; Displays the currently selected filter selections for the
; Held Charges ListManager display
; Input: FILTERS() - Array of filter settings. See FILTERS for a detailed
; explanation of the FILTERS array
; Output: Current Filter settings are displayed
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,IEN,IX,LEN,XX,PFLG,STDT
S STDT=$P(FILTERS(0),U)
W !!!,"Show From Date: ",$S(STDT=0:"First",1:$$FMTE^XLFDT(STDT,"2DZ"))
W !," Thru Date: ",$$FMTE^XLFDT($P(FILTERS(0),U,2),"2DZ")
W !,"Show All Divisions or Selected Divisions: "
W $S($P(FILTERS(0),U,3)=0:"All",1:"Selected")
;
; Division list (if any)
I ($P(FILTERS(0),U,3)=1) D
. S LINE="Divisions to Display: "
. S IEN=0,PFLG=0
. F S IEN=$O(FILTERS(1,IEN)) Q:IEN="" D
. . S XX=$$GET1^DIQ(4,IEN_",",.01)
. . S LINE=LINE_$S(LINE="Divisions to Display: ":"",1:", ")_XX
. W !,$$WRAP(.LINE,.PFLG,80)
. F I=0:0 Q:'PFLG W !,?22,$$WRAP(.LINE,.PFLG,58)
;
W !,"Show All Patients or Selected Patients: "
W $S($P(FILTERS(0),U,4)=0:"All",1:"Selected")
; Patient Inclusion list (if any)
I ($P(FILTERS(0),U,4)=1) D
. S LINE="Patients to Display: "
. S IEN=0,PFLG=0
. F S IEN=$O(FILTERS(2,IEN)) Q:IEN="" D
. . S XX=$$GET1^DIQ(2,IEN_",",.01)
. . S LINE=LINE_$S(LINE="Patients to Display: ":"",1:", ")_XX
. W !,$$WRAP(.LINE,.PFLG,80)
. F I=0:0 Q:'PFLG W !,?21,$$WRAP(.LINE,.PFLG,60)
;
W !,"Include Insurance information on the Held Charges list? ",$S(FILTERS(3)=1:"Yes",1:"No")
K DIR
D PAUSE^VALM1
Q
;
WRAP(STR,FLG,CL) ;
; STR - STRING TO BE WRAPPED PASSED IN BE REFERENCE SO IT CONTAINS THE REMAING PORTION OF STRING
; FLG - FLAG TO INDICATE WRAPPING NEEDS TO OCCUR
; CL - COLUMN LENGTH
;
; NO WRAPPING REQUIRED
I $L(STR)'>CL S FLG=0 Q STR
S FLG=1
N A,B,C
; POSITION AFTER COLUMN WIDTH BREAK IS A SPACE
I $E(STR,CL+1)=" " S B=$E(STR,1,CL),STR=$E(STR,CL+2,999) Q B
S A=$E(STR,1,CL)
; NO SPACES WITHIN COLUMN WITH, JUST BREAK AT COLUMN WIDTH
I $L(A," ")=1 S STR=$E(STR,CL+1,999) Q A
; BREAK ON LAST SEMICOLON PIECE WITHIN COLUMN WIDTH
S C=$L(A," ")
S B=$P(A," ",1,C-1)
S STR=$P(A," ",C)_$E(STR,CL+1,999)
Q B
;
CHKFILT ; Check Filters
N IBSTAT,IBXX,IBXXX,IBXXXX,IBFST,IBDIVS
I $G(VAUTD)=1 S $P(FILTERS(0),U,3)=0,IBDIVS="All"
I $G(VAUTD)=0 D
.S $P(FILTERS(0),U,3)=1
.S IBSTAT=0,IBFST=1
.F S IBSTAT=$O(VAUTD(IBSTAT)) Q:IBSTAT="" D
..S IBXX=$E($$GET1^DIQ(40.8,IBSTAT_",",.01),1,15)
..S IBXXX=$$GET1^DIQ(40.8,IBSTAT_",",1,"E")
..S IBXXXX=$$GET1^DIQ(40.8,IBSTAT_",",.07,"I")
..I 'IBFST S IBDIVS=IBDIVS_","_IBXX_"-"_IBXXX
..I IBFST S IBFST=0,IBDIVS=IBXX_"-"_IBXXX
..S FILTERS(1,IBXXXX)=IBXX_"-"_IBXXX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOHLS 13079 printed Sep 23, 2025@20:01:57 Page 2
IBOHLS ;ALB/JWS,BAA - IB HELD CHARGES LIST MANAGER ;08-SEP-2015
+1 ;;2.0;INTEGRATED BILLING;**554**;21-MAR-94;Build 81
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; -- main entry point for HELD CHARGES LIST
+1 ; add code to do filters here
+2 NEW FILTERS
+3 IF '$$FILTER(.FILTERS)
QUIT
+4 ;
+5 ; code to do sort
+6 DO SORT
+7 ;
+8 DO EN^VALM("IBOH HELD CHARGES LIST")
+9 DO ^%ZISC
+10 QUIT
+11 ;
HDR ; -- header code
+1 ;
+2 NEW BDATE,EDATE,INSTS,PATS,IINS,OLDH
+3 NEW VAL,T1,D
+4 SET BDATE=$PIECE(FILTERS(0),U,1)
SET EDATE=$PIECE(FILTERS(0),U,2)
+5 SET INSTS=$PIECE(FILTERS(0),U,3)
SET PATS=$PIECE(FILTERS(0),U,4)
+6 SET IINS=FILTERS(3)
+7 ;
+8 IF 'INSTS
SET T1="All Divisions Selected"
+9 IF INSTS
Begin DoDot:1
+10 SET T1="Divisions : "
+11 SET D=0
FOR
SET D=$ORDER(FILTERS(1,D))
if D=""
QUIT
SET T1=T1_$SELECT(T1="Divisions : ":"",1:", ")_$PIECE(FILTERS(1,D),"-",2)
End DoDot:1
+12 SET VALMHDR(1)=T1
+13 SET VALMSG="* No Associated Clinic"
+14 QUIT
+15 ;
INIT ; -- init variables and list array
+1 ; input - none
+2 ; output ^TMP($J,"IBOHLS")
+3 NEW BDATE,EDATE,INSTS,PATS,IINS,OLDH
+4 SET BDATE=$PIECE(FILTERS(0),U,1)
SET EDATE=$PIECE(FILTERS(0),U,2)
+5 SET INSTS=$PIECE(FILTERS(0),U,3)
SET PATS=$PIECE(FILTERS(0),U,4)
+6 SET IINS=FILTERS(3)
+7 DO BLD
+8 QUIT
+9 ;
SORT ; get the data
+1 NEW BDATE,EDATE,INSTS,PATS,IINS,OLDH
+2 SET BDATE=$PIECE(FILTERS(0),U,1)
SET EDATE=$PIECE(FILTERS(0),U,2)
+3 SET INSTS=$PIECE(FILTERS(0),U,3)
SET PATS=$PIECE(FILTERS(0),U,4)
+4 SET IINS=FILTERS(3)
SET CNT=0
+5 SET ^TMP($JOB,"IBOHLSF")=FILTERS(0)
+6 KILL ^TMP($JOB,"IBOHLS")
+7 KILL ^TMP($JOB,"IBHOLD")
+8 KILL ^TMP($JOB,"IBOHLS INS")
+9 ;
+10 DO SORT^IBOHLS1
+11 QUIT
+12 ;
EXPAND ; -- expand code
+1 DO FULL^VALM1
+2 NEW I,J,IBXX,VALMY,ECNT,PNAME,DFN,IBHLD0,REC,IBIEN,LST,CLINIC
+3 DO EN^VALM2($GET(XQORNOD(0)))
+4 ;W !,"Entry ",X,"Selected" D
IF $DATA(VALMY)
SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+5 KILL ^TMP($JOB,"IBOHLE")
+6 SET REC=$GET(^TMP($JOB,"IBOHLSX",IBXX))
+7 SET DFN=$PIECE(REC,U,1)
SET PNAME=$PIECE(REC,U,2)
SET ECNT=$PIECE(REC,U,3)
+8 SET IBIEN=$PIECE(^TMP($JOB,"IBOHLS",PNAME,ECNT,"IBND"),U,3)
+9 SET LST=$PIECE(^TMP($JOB,"IBOHLS",PNAME,ECNT,"IBND"),U,6)
+10 SET CLINIC=$PIECE(^TMP($JOB,"IBOHLS",PNAME,ECNT,"IBND"),U,8)
+11 if IBIEN=""
QUIT
+12 SET ^TMP($JOB,"IBOHLSE")=DFN_U_ECNT_U_PNAME_U_IBIEN_U_LST_U_CLINIC
+13 DO EN^VALM("IBOH HELD CHARGES EXPAND")
+14 QUIT
End DoDot:1
+15 DO BLD
+16 SET VALMBCK="R"
+17 QUIT
+18 ;
BLD ; build data to display
+1 ; build display
+2 KILL ^TMP($JOB,"IBOHLSX")
+3 KILL ^TMP("VALMAR",$JOB)
+4 NEW FIRST,VCNT,CNT,NAME,BCNT,RNB,RX,CLINIC,INST,DNAME,FLAG
+5 SET VALMCNT=0
+6 SET (CNT,VCNT)=0
SET NAME=""
+7 FOR
SET NAME=$ORDER(^TMP($JOB,"IBOHLS",NAME))
if NAME=""
QUIT
Begin DoDot:1
+8 SET FIRST=1
+9 FOR
SET CNT=$ORDER(^TMP($JOB,"IBOHLS",NAME,CNT))
if CNT=""
QUIT
Begin DoDot:2
+10 SET FLAG=""
SET FLAG=$PIECE(^TMP($JOB,"IBOHLS",NAME,CNT,"IBND"),U,7)
+11 SET INST=""
SET INST=$PIECE(^TMP($JOB,"IBOHLS",NAME,CNT,"IBND"),U,6)
+12 SET CLINIC=""
SET CLINIC=$PIECE(^TMP($JOB,"IBOHLS",NAME,CNT,"IBND"),U,8)
+13 SET VCNT=VCNT+1
+14 ;line#
SET LINE=$$SETL("",VCNT,"",1,5)
+15 SET XX=^TMP($JOB,"IBOHLS",NAME,CNT)
+16 SET DFN=$PIECE(^TMP($JOB,"IBOHLS",NAME,CNT,"IBND"),U,1)
+17 SET DNAME=FLAG_$PIECE(XX,U)
+18 SET LINE=$$SETL(LINE,DNAME,"",6,21)
+19 SET LINE=$$SETL(LINE,$PIECE(XX,U,2),"",28,6)
+20 SET LINE=$$SETL(LINE,$PIECE(XX,U,3),"",37,6)
+21 SET LINE=$$SETL(LINE,$$FMTE^XLFDT($PIECE(XX,U,4),"2DZ"),"",44,8)
+22 SET LINE=$$SETL(LINE,$$FMTE^XLFDT($PIECE(XX,U,5),"2DZ"),"",54,8)
+23 SET LINE=$$SETL(LINE,$PIECE(XX,U,6),"",64,5)
+24 SET LINE=$$SETL(LINE,$JUSTIFY($PIECE(XX,U,7),8,2),"",72,8)
+25 SET VALMCNT=VALMCNT+1
+26 DO SET^VALM10(VALMCNT,LINE,VCNT)
+27 SET LINE=$$SETL("","Division: "_INST_" - "_CLINIC,"",6,60)
+28 SET VALMCNT=VALMCNT+1
+29 DO SET^VALM10(VALMCNT,LINE,VCNT)
+30 SET ^TMP($JOB,"IBOHLSX",VCNT)=DFN_U_NAME_U_CNT_U_INST_U_FLAG_U_CLINIC
+31 IF $DATA(^TMP($JOB,"IBOHLS",NAME,CNT,1))
Begin DoDot:3
+32 SET RX=^TMP($JOB,"IBOHLS",NAME,CNT,1)
SET RX="Rx#:"_RX
+33 SET LINE=$$SETL("",RX,"",37,20)
+34 SET VALMCNT=VALMCNT+1
+35 DO SET^VALM10(VALMCNT,LINE,VCNT)
End DoDot:3
+36 IF $DATA(^TMP($JOB,"IBOHLS",NAME,CNT,2))
Begin DoDot:3
+37 SET BCNT=0
FOR
SET BCNT=$ORDER(^TMP($JOB,"IBOHLS",NAME,CNT,2,BCNT))
if BCNT=""
QUIT
Begin DoDot:4
+38 SET XX=^TMP($JOB,"IBOHLS",NAME,CNT,2,BCNT)
+39 SET LINE=$$SETL("","Bill: ","",6,6)
+40 SET LINE=$$SETL(LINE,$PIECE(XX,U),"",14,10)
+41 SET LINE=$$SETL(LINE,$PIECE(XX,U,2),"",26,10)
+42 SET LINE=$$SETL(LINE,$$FMTE^XLFDT($PIECE(XX,U,3),"2DZ"),"",38,10)
+43 SET LINE=$$SETL(LINE,$$FMTE^XLFDT($PIECE(XX,U,4),"2DZ"),"",50,10)
+44 SET LINE=$$SETL(LINE,$PIECE(XX,U,5),"",62,4)
+45 SET LINE=$$SETL(LINE,$JUSTIFY($PIECE(XX,U,6),8,2),"",68,10)
+46 SET VALMCNT=VALMCNT+1
+47 DO SET^VALM10(VALMCNT,LINE,VCNT)
+48 SET RNB=$PIECE(XX,U,7)
+49 IF RNB'=""
Begin DoDot:5
+50 SET LINE=$$SETL("","RNB: ","",6,6)
+51 SET LINE=$$SETL(LINE,RNB,"",14,60)
+52 SET VALMCNT=VALMCNT+1
+53 DO SET^VALM10(VALMCNT,LINE,VCNT)
End DoDot:5
End DoDot:4
End DoDot:3
+54 ; IF DISPLAYING INSURANCE INFORMATION
IF $DATA(^TMP($JOB,"IBOHLS INS",NAME))
IF FIRST
Begin DoDot:3
+55 SET FIRST=0
+56 NEW ZZ,ZZ1,ZZ2
+57 SET LINE=$$SETL("","Insurance","",6,9)
+58 SET LINE=$$SETL(LINE,"Subscriber","",24,10)
+59 SET LINE=$$SETL(LINE,"Group","",42,5)
+60 SET LINE=$$SETL(LINE,"Eff Dt","",58,6)
+61 SET LINE=$$SETL(LINE,"Exp Dt","",70,6)
+62 SET VALMCNT=VALMCNT+1
+63 DO SET^VALM10(VALMCNT,LINE,VCNT)
+64 SET VALMCNT=VALMCNT+1
+65 SET $PIECE(ZZ2,"-",78)=""
+66 SET LINE=$$SETL("",ZZ2,"",6,78)
+67 DO SET^VALM10(VALMCNT,LINE,VCNT)
+68 SET ZZ=0
FOR
SET ZZ=$ORDER(^TMP($JOB,"IBOHLS INS",NAME,ZZ))
if ZZ=""
QUIT
Begin DoDot:4
+69 SET ZZ1=^TMP($JOB,"IBOHLS INS",NAME,ZZ)
+70 SET LINE=$$SETL("",$PIECE(ZZ1,U),"",6,15)
+71 SET LINE=$$SETL(LINE,$PIECE(ZZ1,U,2),"",24,15)
+72 SET LINE=$$SETL(LINE,$PIECE(ZZ1,U,3),"",42,14)
+73 SET LINE=$$SETL(LINE,$$FMTE^XLFDT($PIECE(ZZ1,U,4),"2DZ"),"",58,10)
+74 SET LINE=$$SETL(LINE,$$FMTE^XLFDT($PIECE(ZZ1,U,5),"2DZ"),"",70,10)
+75 SET VALMCNT=VALMCNT+1
+76 DO SET^VALM10(VALMCNT,LINE,VCNT)
+77 IF '$ORDER(^TMP($JOB,"IBOHLS INS",NAME,ZZ,0))
QUIT
+78 SET LINE=$$SETL("","Plan Coverage Eff. Date Covered? Limit Comments","",10,60)
+79 SET VALMCNT=VALMCNT+1
+80 DO SET^VALM10(VALMCNT,LINE,VCNT)
+81 SET ZZ2=0
FOR
SET ZZ2=$ORDER(^TMP($JOB,"IBOHLS INS",NAME,ZZ,ZZ2))
if ZZ2=""
QUIT
Begin DoDot:5
+82 SET ZZ1=^TMP($JOB,"IBOHLS INS",NAME,ZZ,ZZ2)
+83 SET LINE=$$SETL("",$PIECE(ZZ1,U),"",10,15)
+84 SET LINE=$$SETL(LINE,$PIECE(ZZ1,U,2),"",27,8)
+85 SET LINE=$$SETL(LINE,$PIECE(ZZ1,U,3),"",40,12)
+86 SET LINE=$$SETL(LINE,$PIECE(ZZ1,U,4),"",55,25)
+87 SET VALMCNT=VALMCNT+1
+88 DO SET^VALM10(VALMCNT,LINE,VCNT)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+89 QUIT
+90 ;
SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
+1 ; of the worklist
+2 ; Input: LINE - Current line being created
+3 ; DATA - Information to be added to the end of the current line
+4 ; LABEL - Label to describe the information being added
+5 ; COL - Column position in line to add information add
+6 ; LNG - Maximum length of data information to include on the line
+7 ; Returns: Line updated with added information
+8 SET LINE=LINE_$JUSTIFY("",(COL-$LENGTH(LABEL)-$LENGTH(LINE)))_LABEL_$EXTRACT(DATA,1,LNG)
+9 QUIT LINE
+10 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP($JOB,"IBOHLSF")
+2 KILL ^TMP($JOB,"IBOHLS")
+3 KILL ^TMP($JOB,"IBHOLD")
+4 KILL ^TMP($JOB,"IBOHLS INS")
+5 ;
+6 DO CLEAR^VALM1
DO CLEAN^VALM10
+7 DO ^%ZISC
+8 QUIT
+9 ;
FILTER(FILTERS) ; filter display
+1 ; Sets an array of filters to determine which entris to include in display
+2 ; Input: None
+3 ; Output:
+4 ; Returns: 0 if the user entered '^' or timed out, 1 otherwise
+5 ; FILTERS(0) = from date ^ to date ^ 0 (all) 1 (selected) institutions ^ 0 (all) 1 (selected) patients
+6 ; FILTERS(1,inst ien) = ""
+7 ; FILTERS(2,pat ien) = ""
+8 ; FILTERS(3) = 0 (NO) 1 (YES) to include insurance information
+9 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XX,Y,IBDATES
+10 KILL FILTERS
+11 ; get date range
+12 SET IBDATES="Date of Service"
SET IBDATES=$$FMDATES(IBDATES)
IF IBDATES=0
QUIT 0
+13 SET FILTERS(0)=IBDATES
+14 ;
+15 ; Site (Division) filter
+16 WRITE !
+17 DO PSDR^IBODIV
+18 DO CHKFILT
+19 ;
+20 ; Patient filter
+21 SET DIR(0)="S"
SET DIR("A")="Select(A)ll or (S)elected Patient(s):"
SET DIR("B")="All"
+22 SET DIR("?",1)="Enter 'A' to not filter by Patient."
+23 SET DIR("?")="Enter 'S' to view entries for selected Patients."
+24 SET $PIECE(DIR(0),U,2)="A:All Patients;S:Selected Patients"
+25 WRITE !
DO ^DIR
KILL DIR
+26 IF $GET(DIRUT)
QUIT 0
+27 SET X=$$UP^XLFSTR(X)
+28 SET $PIECE(FILTERS(0),U,4)=$SELECT(Y="A":0,1:1)
+29 ; Set Patient / Veteran filter
+30 IF $PIECE(FILTERS(0),U,4)=1
DO ASKPAT(.FILTERS)
+31 ;
+32 SET DIR(0)="Y"
SET DIR("A")="Include Insurance information on the Held Charges list"
SET DIR("B")="NO"
+33 SET DIR("?",1)=" Enter: 'Y' - to include patient insurance information on the Held Charges list"
+34 SET DIR("?",2)=" 'N' - to exclude patient insurance information on the Held Charges list"
+35 SET DIR("?",3)=" '^' - to exit this option"
+36 DO ^DIR
KILL DIR
+37 IF $GET(DIRUT)
QUIT 0
+38 SET FILTERS(3)=+Y
+39 DO SHOWFILT(.FILTERS)
+40 IF X="^"
QUIT 0
+41 QUIT 1
+42 ;
FMDATES(PROMPT) ; ask for date range
+1 NEW %DT,X,Y,DT1,DT2,IB0,IB1,IB2
+2 SET DIR(0)="S"
SET DIR("A")="Select(A)ll or (S)elected Date(s):"
SET DIR("B")="All"
+3 SET DIR("?",1)="Enter 'A' to view all Dates."
+4 SET DIR("?")="Enter 'S' to view entries for selected Dates."
+5 SET $PIECE(DIR(0),U,2)="A:All Dates;S:Selected Dates"
+6 WRITE !
DO ^DIR
KILL DIR
+7 IF X="^"
QUIT 0
+8 IF $GET(DIRUT)
QUIT 0
+9 IF $EXTRACT(Y)="A"
SET DT1=0_U_DT
GOTO FMDQ
+10 SET DT1=""
SET IB1="Start with date entered: "
SET IB2="Go to date entered: "
+11 IF $GET(PROMPT)'=""
SET IB1="Start with "_PROMPT_": "
SET IB2="Go to "_PROMPT_": "
+12 SET %DT="AEX"
SET %DT("A")=IB1
DO ^%DT
KILL %DT
IF Y<0!($PIECE(Y,".",1)'?7N)
GOTO FMDQ
+13 SET (%DT(0),DT2)=$PIECE(Y,".",1)
IF DT2'>DT
SET %DT("B")="Today"
+14 SET %DT="AEX"
SET %DT("A")=IB2
DO ^%DT
KILL %DT
IF Y<0!($PIECE(Y,".",1)'?7N)
GOTO FMDQ
+15 SET DT1=DT2_U_$PIECE(Y,".",1)
FMDQ QUIT DT1
+1 ;
+2 ;
ASKPAT(FILTERS) ; Sets a list of patients
+1 ; the HCSR Worklist
+2 ; Input: FILTERS - Current Array of filter settings
+3 ; Output: FILTERS - Updated Array of filter settings
+4 NEW CLINS,DIC,DIR,DIRUT,IBDIVS,DUOUT,FIRST,IBIENS,IBIENS2,IEN,N,NM,NODE,WARDS,X,XX,Y
+5 SET DIC(0)="AEQMN"
SET DIC="^DPT("
SET FIRST=1
+6 FOR
Begin DoDot:1
+7 ; One patient
DO ONEPAT(.DIC,.IEN,.FIRST)
+8 if +IEN<1
QUIT
+9 SET IBIENS($PIECE(IEN,U,2))=$PIECE(IEN,U,1)
+10 SET IBIENS2($PIECE(IEN,U,1))=$PIECE(IEN,U,2)
End DoDot:1
if +IEN<1
QUIT
+11 IF '$DATA(IBIENS)
SET $PIECE(FILTERS(0),U,4)=0
QUIT
+12 ;
+13 ; Set the filter node responses in alphabetical order
+14 SET XX=""
+15 FOR
Begin DoDot:1
+16 SET XX=$ORDER(IBIENS(XX))
+17 if XX=""
QUIT
+18 SET N=IBIENS(XX)
+19 SET FILTERS(2,N)=""
+20 ;S FILTERS(2)=$S($G(FILTERS(2))'="":FILTERS(2)_U_N,1:N)
End DoDot:1
if XX=""
QUIT
+21 QUIT
+22 ;
ONEPAT(DIC,IEN,FIRST) ; Prompts the user for a clinic or ward
+1 ; Input: DIC - Variable/Array of settings needed for ^DIC call
+2 ; FIRST - Set to 1 initially and then 0 for subsequent calls
+3 ; Output: FIRST - Set to 0
+4 ; IEN - IEN of the selected Ward or clinic Entry
+5 ; null of no selection was made
+6 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+7 SET DIC("A")=$SELECT(FIRST:"Select Patient: ",1:"Select Another Patient: ")
+8 DO ^DIC
+9 SET FIRST=0
SET IEN=Y
+10 SET DFN=+Y
+11 QUIT
+12 ;
SHOWFILT(FILTERS) ;EP
+1 ; Displays the currently selected filter selections for the
+2 ; Held Charges ListManager display
+3 ; Input: FILTERS() - Array of filter settings. See FILTERS for a detailed
+4 ; explanation of the FILTERS array
+5 ; Output: Current Filter settings are displayed
+6 ;
+7 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,IEN,IX,LEN,XX,PFLG,STDT
+8 SET STDT=$PIECE(FILTERS(0),U)
+9 WRITE !!!,"Show From Date: ",$SELECT(STDT=0:"First",1:$$FMTE^XLFDT(STDT,"2DZ"))
+10 WRITE !," Thru Date: ",$$FMTE^XLFDT($PIECE(FILTERS(0),U,2),"2DZ")
+11 WRITE !,"Show All Divisions or Selected Divisions: "
+12 WRITE $SELECT($PIECE(FILTERS(0),U,3)=0:"All",1:"Selected")
+13 ;
+14 ; Division list (if any)
+15 IF ($PIECE(FILTERS(0),U,3)=1)
Begin DoDot:1
+16 SET LINE="Divisions to Display: "
+17 SET IEN=0
SET PFLG=0
+18 FOR
SET IEN=$ORDER(FILTERS(1,IEN))
if IEN=""
QUIT
Begin DoDot:2
+19 SET XX=$$GET1^DIQ(4,IEN_",",.01)
+20 SET LINE=LINE_$SELECT(LINE="Divisions to Display: ":"",1:", ")_XX
End DoDot:2
+21 WRITE !,$$WRAP(.LINE,.PFLG,80)
+22 FOR I=0:0
if 'PFLG
QUIT
WRITE !,?22,$$WRAP(.LINE,.PFLG,58)
End DoDot:1
+23 ;
+24 WRITE !,"Show All Patients or Selected Patients: "
+25 WRITE $SELECT($PIECE(FILTERS(0),U,4)=0:"All",1:"Selected")
+26 ; Patient Inclusion list (if any)
+27 IF ($PIECE(FILTERS(0),U,4)=1)
Begin DoDot:1
+28 SET LINE="Patients to Display: "
+29 SET IEN=0
SET PFLG=0
+30 FOR
SET IEN=$ORDER(FILTERS(2,IEN))
if IEN=""
QUIT
Begin DoDot:2
+31 SET XX=$$GET1^DIQ(2,IEN_",",.01)
+32 SET LINE=LINE_$SELECT(LINE="Patients to Display: ":"",1:", ")_XX
End DoDot:2
+33 WRITE !,$$WRAP(.LINE,.PFLG,80)
+34 FOR I=0:0
if 'PFLG
QUIT
WRITE !,?21,$$WRAP(.LINE,.PFLG,60)
End DoDot:1
+35 ;
+36 WRITE !,"Include Insurance information on the Held Charges list? ",$SELECT(FILTERS(3)=1:"Yes",1:"No")
+37 KILL DIR
+38 DO PAUSE^VALM1
+39 QUIT
+40 ;
WRAP(STR,FLG,CL) ;
+1 ; STR - STRING TO BE WRAPPED PASSED IN BE REFERENCE SO IT CONTAINS THE REMAING PORTION OF STRING
+2 ; FLG - FLAG TO INDICATE WRAPPING NEEDS TO OCCUR
+3 ; CL - COLUMN LENGTH
+4 ;
+5 ; NO WRAPPING REQUIRED
+6 IF $LENGTH(STR)'>CL
SET FLG=0
QUIT STR
+7 SET FLG=1
+8 NEW A,B,C
+9 ; POSITION AFTER COLUMN WIDTH BREAK IS A SPACE
+10 IF $EXTRACT(STR,CL+1)=" "
SET B=$EXTRACT(STR,1,CL)
SET STR=$EXTRACT(STR,CL+2,999)
QUIT B
+11 SET A=$EXTRACT(STR,1,CL)
+12 ; NO SPACES WITHIN COLUMN WITH, JUST BREAK AT COLUMN WIDTH
+13 IF $LENGTH(A," ")=1
SET STR=$EXTRACT(STR,CL+1,999)
QUIT A
+14 ; BREAK ON LAST SEMICOLON PIECE WITHIN COLUMN WIDTH
+15 SET C=$LENGTH(A," ")
+16 SET B=$PIECE(A," ",1,C-1)
+17 SET STR=$PIECE(A," ",C)_$EXTRACT(STR,CL+1,999)
+18 QUIT B
+19 ;
CHKFILT ; Check Filters
+1 NEW IBSTAT,IBXX,IBXXX,IBXXXX,IBFST,IBDIVS
+2 IF $GET(VAUTD)=1
SET $PIECE(FILTERS(0),U,3)=0
SET IBDIVS="All"
+3 IF $GET(VAUTD)=0
Begin DoDot:1
+4 SET $PIECE(FILTERS(0),U,3)=1
+5 SET IBSTAT=0
SET IBFST=1
+6 FOR
SET IBSTAT=$ORDER(VAUTD(IBSTAT))
if IBSTAT=""
QUIT
Begin DoDot:2
+7 SET IBXX=$EXTRACT($$GET1^DIQ(40.8,IBSTAT_",",.01),1,15)
+8 SET IBXXX=$$GET1^DIQ(40.8,IBSTAT_",",1,"E")
+9 SET IBXXXX=$$GET1^DIQ(40.8,IBSTAT_",",.07,"I")
+10 IF 'IBFST
SET IBDIVS=IBDIVS_","_IBXX_"-"_IBXXX
+11 IF IBFST
SET IBFST=0
SET IBDIVS=IBXX_"-"_IBXXX
+12 SET FILTERS(1,IBXXXX)=IBXX_"-"_IBXXX
End DoDot:2
End DoDot:1
+13 QUIT
