IBTRH1 ;ALB/FA - HCSR Worklist ;01-JUL-2014
;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
;;Per VA Directive 6402, this routine should not be modified.
;;
;
EN ;EP
; Main entry point for HCSR Worklist
; Input: None
N HCSRSORT,IBFILTS
Q:'$$FILTERS^IBTRH1A(.IBFILTS) ; Returns an array of filter settings
D SORT(1) ; Sort the entries
D EN^VALM("IBT HCSR WORKLIST")
Q
;
HDR ;EP
; Header code for HCSR Worklist
; Input: HCSRSORT - Current sort selection
; IBFILTS() - Array of filter criteria
; Output: VALMHDR - Header information to display
; VALM("TITLE") - HCSR Worklist Title
; VALMSG - Initial Error line display
N XX
S:$G(HCSRSORT)="" HCSRSORT="1^Oldest Entries First"
S VALMHDR(1)=$$FILTBY(.IBFILTS)
S VALMHDR(2)="Sorted By: "_$P(HCSRSORT,"^",2)
S VALM("TITLE")="HCSR Worklist"
D VALMSGH ; Set flag legend
Q
;
VALMSGH(INP) ;EP
; Sets the legend into variable VALMSG
; Input: INP - 1 - Only display #In-Prog, 0 - Display all
; Optional, defaults to 0
; Output: VALMSG is set
S:'$D(INP) INP=0
I INP S VALMSG="#In-Prog" Q
S VALMSG="?Await #In-Prog -RespErr !Unable +Pend *NextRev"
Q
;
FILTBY(IBFILTS) ;EP
; Creates the 'Filtered By' line of the worklist header
; Input: IBFILT - Array of current filter settings
; Returns: Filtered By line
N XX
I $P(IBFILTS(0),"^",2)=0 S XX="CPAC, "
I $P(IBFILTS(0),"^",2)=1 S XX="CHAMPVA/TRICARE, "
I $P(IBFILTS(0),"^",2)=2 S XX="Both CPAC and CHAMPVA/TRICARE, "
S XX=XX_$S($G(IBFILTS(3))'="":"Sel Div, ",1:"All Div, ")
I $P(IBFILTS(0),"^",1)=0 D
. S XX=XX_$S($G(IBFILTS(1))'="":"Sel Outpt",1:"All Outpt")
I $P(IBFILTS(0),"^",1)=1 D
. S XX=XX_$S($G(IBFILTS(2))'="":"Sel Inpt",1:"All Inpt")
I $P(IBFILTS(0),"^",1)=2 D
. S XX=XX_$S($G(IBFILTS(1))'="":"Sel Outpt, ",1:"All Outpt, ")
. S XX=XX_$S($G(IBFILTS(2))'="":"Sel Inpt",1:"All Inpt")
Q "Filtered By: "_XX
;
INIT ;EP
; Initialize variables and list array
; Input: None
; Output: HCSRSORT - Initial worklist sort if not yet defined
; IBFILTS() - Array of filter criteria
; ^TMP("IBTRH1",$J) - Body lines to display
K ^TMP("IBTRH1",$J),^TMP($J,"IBTRH1IX")
S:$G(HCSRSORT)="" HCSRSORT="1^Oldest Entries First"
D BLD
Q
;
BLD ; Build screen array, no variables required for input
; Input: HCSRSORT - Current select sort type
; IBFILTS() - Array of filter criteria
; Output: ^TMP("IBTRH1",$J) - Body lines to display
; ^TMP($J,"IBTRH1S") - Sorted Body lines to display
; ^TMP($J,"IBTRH1IX") - Index of Entry IENs by display line
N DA,ECTR,LINE,S1,S2,S3,XSELCNT,XDA1,XRESP,XREJDA,XREJDA1
; Build the sorted list of lines to display
D SORT1^IBTRH1A
S (ECTR,VALMCNT)=0,S1=""
F S S1=$O(^TMP($J,"IBTRH1S",S1)) Q:S1="" D
.S S2="" F S S2=$O(^TMP($J,"IBTRH1S",S1,S2)) Q:S2="" D
..S S3="" F S S3=$O(^TMP($J,"IBTRH1S",S1,S2,S3)) Q:S3="" D
...S DA="" F S DA=$O(^TMP($J,"IBTRH1S",S1,S2,S3,DA)) Q:DA="" D
....S ECTR=ECTR+1
....S LINE=^TMP($J,"IBTRH1S",S1,S2,S3,DA)
....S LINE=$$BLDLN(ECTR,LINE)
....S VALMCNT=VALMCNT+1,XSELCNT=$G(XSELCNT)+1
....D SET^VALM10(VALMCNT,LINE,XSELCNT),BLD1
....S ^TMP($J,"IBTRH1IX",XSELCNT)=DA
....S XRESP=$P(^IBT(356.22,DA,0),U,14)
....I XRESP'="" S XDA1=$G(^IBT(356.22,XRESP,103))
....I $P($G(XDA1),U,3)'="" D
.....N XREVDA1
.....D GETS^DIQ(356.021,$P(XDA1,U,3),".01:.02",,"XREVDA1")
.....S VALMCNT=VALMCNT+1
.....D SET^VALM10(VALMCNT," Review Decision: "_XREVDA1(356.021,$P(XDA1,U,3)_",",".01")_" - "_XREVDA1(356.021,$P(XDA1,U,3)_",",".02"),XSELCNT)
.....D BLD1
....I XRESP'="" S XDA1=0 F S XDA1=$O(^IBT(356.22,XRESP,101,XDA1)) Q:'XDA1 D
.....S XREJDA=+$P($G(^IBT(356.22,XRESP,101,XDA1,0)),U,4) I 'XREJDA Q
.....D GETS^DIQ(365.017,XREJDA,".01:.02",,"XREJDA1")
.....S VALMCNT=VALMCNT+1
.....D SET^VALM10(VALMCNT," Rejection: "_XREJDA1(365.017,XREJDA_",",".01")_" - "_XREJDA1(365.017,XREJDA_",",".02"),XSELCNT)
.....D BLD1
.....S XDA1=""
.....Q
....Q
...Q
..Q
.Q
I VALMCNT=0 D
.S ^TMP("IBTRH1",$J,1,0)="There are no entries to display."
Q
;
BLD1 ;
S ^TMP("IBTRH1",$J,"IDXX",XSELCNT,VALMCNT)=""
Q
;
BLDLN(ECTR,LINED) ; Builds a line to display on List screen for one entry
; Input: ECTR - Entry counter
; LINED - A1^A2^...A9 Where:
; A1 - Patient Name
; A2 - Patient Status ('I' or 'O')
; A3 - External Appt or Admission date
; A4 - Clinic or Ward name
; A5 - COB ('P' or 'S')
; A6 - Insurance Company Name
; A7 - Utilization Review required
; A8 - Pre-Certification required
; A9 - Service Connection flags
; Output: LINE - Formatted for setting into the list display
N LINE,LINEI
S LINE=$$SETSTR^VALM1(ECTR,"",1,4) ; Entry #
S LINE=$$SETSTR^VALM1($P(LINED,"^",1),LINE,6,23) ; Patient Name
S LINE=$$SETSTR^VALM1($P(LINED,"^",2),LINE,30,1) ; Patient Status
S LINE=$$SETSTR^VALM1($P(LINED,"^",3),LINE,32,8) ; Appt/Adm Date
S LINE=$$SETSTR^VALM1($P(LINED,"^",4),LINE,41,10) ; Clinic or Ward
S LINE=$$SETSTR^VALM1($P(LINED,"^",5),LINE,52,1) ; COB
S LINE=$$SETSTR^VALM1($P(LINED,"^",6),LINE,55,14) ; Insurance Name
S LINE=$$SETSTR^VALM1($P(LINED,"^",7),LINE,70,1) ; UR required
S LINE=$$SETSTR^VALM1($P(LINED,"^",8),LINE,72,1) ; Pre-Cert Required
S LINE=$$SETSTR^VALM1($P(LINED,"^",9),LINE,74,5) ; Service Connections
Q LINE
;
HELP ;EP
; Help code
; Input: None
D FULL^VALM1
S VALMBCK="R"
W @IOF,"Flags displayed on screen for SC Reas (Service Connected Reason):"
W !," A - Agent Orange"
W !," I - Ionizing Radiation"
W !," S - Southwest Asia"
W !," N - Nose/Throat Radium"
W !," C - Combat Veteran"
W !," M - Military Sexual Trauma (MST)"
W !," L - Camp Lejeune"
W !,"Flags displayed on screen for U (UR Required) or P (Pre-certification Required):"
W !," Y - Yes, N - No"
W !,"Flags displayed on screen for S (Patient Status):"
W !," O - Outpatient, I - Inpatient"
W !,"The following Status indicators may appear to the left of the patient name:"
W !," # - 278 has been not been initiated, entry is in-progress"
W !," ? - 278 has been sent and waiting for response"
W !," + - 278 is pending"
W !," * - Flagged for Next Review"
W !," ! - Unable to send 278"
W !," <Blank> - Entry added through scheduled task"
W !," - - 278 has been sent and negative response received "
W !," (error AAA condition in AAA segment(s))"
S VALMSG="?Await #In-Prog -RespErr !Unable +Pend *NextRev"
Q
;
EXIT ;EP
; Exit code
; Input: None
K ^TMP("IBTRH1",$J),^TMP($J,"IBTRH1IX"),^TMP($J,"IBTRH1S")
K HCSRSORT
D CLEAR^VALM1
Q
;
SORT(FIRST) ;EP
; Listman Protocol Action to sort the worklist
; Input: FIRST - 1 - Called for the first time before the Worklist is displayed
; 2 - Called from Refresh action (REFRESH^IBTRH1A)
; 0 - Called as an action from within the Worklist, Optional, defaults to 0
; HCSRSORT - Current sort selection (null if FIRST=1)
; IBFILTS()- Array of filter criteria
; Output: HCSRSORT - New sort selection and list is sorted
N CTR,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ST,STDES,X,XX,Y
D VALMSGH ; Set flag legend
S CTR=1
S:'$D(FIRST) FIRST=0
S:FIRST=1 HCSRSORT="1^Oldest Entries First"
I 'FIRST!(FIRST=2) D
. D:'FIRST FULL^VALM1
. W:'FIRST @IOF
. W !,"Select the item to sort the records on the HCSR Worklist screen."
S XX="SO^"_CTR_":Oldest Entries First",CTR=CTR+1
S XX=XX_";"_CTR_":Newest Entries First",CTR=CTR+1
S:+IBFILTS(0)=2 XX=XX_";"_CTR_":Outpatient Appointments First",CTR=CTR+1
S:+IBFILTS(0)=2 XX=XX_";"_CTR_":Inpatient Admissions First",CTR=CTR+1
S XX=XX_";"_CTR_":Insurance Company Name"
S DIR(0)=XX
S DIR("A")="Sort the list by",DIR("B")=$P($G(HCSRSORT),"^",2)
D ^DIR K DIR
I 'Y S VALMBCK="R" Q ; User quit or timed out
S XX=$S(+IBFILTS(0)=2:Y,Y<3:Y,1:5)
S HCSRSORT=XX_"^"_Y(0) ; Sort selection
Q:FIRST
; Rebuild and resort the list and update the list header
D INIT,HDR
S VALMBCK="R",VALMBG=1
Q
;
DEL ;EP
; Protocol Action to select an entry to be manually removed from the worklist
; Input: ^TMP("IBTRH1",$J) - Current Array of displayed entries
; ^TMP($J,"IBTRHIX") - Current Index of displayed entries
; Output: Selected Entry is removed from the worklist
; Error messages display (potentially)
; ^TMP("IBTRH1",$J) - Updated Array of displayed entries
; ^TMP($J,"IBTRHIX") - Updated Index of displayed entries
N DIR,DIROUT,DIRUT,DLINE,DTOUT,DUOUT,EIEN,EIENS,ERROR,IEN,IX,LINE,MSG
N PROMPT,SDATA,DELRCODE,XCOM,COM,DIWETXT
D VALMSGH ; Set flag legend
S VALMBCK="R",ERROR=0
; First select the entry(s) to be removed from the worklist
S PROMPT="Select the worklist entry(s) to be deleted"
S MSG="Are you sure you want to delete "
S EIENS=$$SELEVENT(1,PROMPT,.DLINE,1) ; Select the entry to be deleted
I EIENS="" S VALMBCK="R" Q
D1 ;
S DIC(0)="AEQM",DIC="^IBT(356.023,"
S DIC("A")="Select a Delete Reason Code: "
D ^DIC
I Y<0 Q:X="^" W !,*7,">>>> A Delete Reason Code must be selected, or '^' to exit." G D1
S DELRCODE=$P(Y,"^")
Q:'$$ASKSURE(DLINE,MSG) ; Final warning
F IX=1:1:$L(EIENS,",") D Q:$G(ERROR)
. S EIEN=$P(EIENS,",",IX)
. S LINE=$P(DLINE,",",IX)
. ; Don't allow deletion of entries with a pending response (status '02')
. I +$P(^IBT(356.22,EIEN,0),"^",8)=2 D Q
.. W !,*7,">>>> Entry ",LINE," has been sent and is awaiting a response. It cannot be deleted."
.. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
.. S DIR(0)="EA"
.. S DIR("A",1)=" "
.. S DIR("A")="Press RETURN to continue " D ^DIR
.. S ERROR=1
.. Q
. ; Next update the status to be manually removed
. I '$$LOCKEV(EIEN) D Q
.. W !,*7,">>>> Someone else is editing entry ",LINE,". Try again later."
.. S ERROR=1
. K SDATA
. S IEN=EIEN_","
. S SDATA(356.22,IEN,.08)="06" ; Set Status manual remove flag
. S SDATA(356.22,IEN,.23)=$$NOW^XLFDT() ; Set Manually Removed Date/Time
. S SDATA(356.22,IEN,.24)=DUZ ; Set Manually Removed By User
. S SDATA(356.22,IEN,.25)=DELRCODE ; Set Delete Reason code pointer
. I $P(^IBT(356.22,EIEN,0),"^",11)="" S SDATA(356.22,IEN,.11)=DUZ ; 517-T14: if REQUESTED BY is blank, set it to user deleting
. D FILE^DIE("","SDATA")
. D UNLOCKEV(EIEN)
I $G(ERROR) Q
K DIR
Q
;
ASKSURE(DLINE,MSG,ENTIRE) ;EP
; Make sure the user wants to proceed with the selected action
; Input: DLINE - Comma delimited list of valid selected lines
; MSG - Message to be displayed to the user
; ENTIRE - 1 - MSG is the entire prompt do not append
; 0 - MSG is not the entire prompt append
; Optional, defaults to 0
; Returns: 1 - Proceed with action, 0 otherwise
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XX,Y
S:'$D(ENTIRE) ENTIRE=0
S XX=$S(DLINE[",":"entries ",1:"entry ")
S DIR(0)="YO",DIR("B")="N"
S:'ENTIRE MSG=MSG_XX_DLINE
S DIR("A")=MSG
D ^DIR K DIR
Q:'Y 0
Q 1
;
PRMARK(WHICH,EIENIN,WLIST) ;EP
; Listman Protocol Action to Mark/Remove 'In-Progress' from a selected entry
; Called from HSCR Worklist and HSCR Response Worklist
; Input: WHICH - 0 - Remove 'In-Progress' mark
; 1 - Set 'In-Progress' mark
; EIENIN - IEN of the entry to Mark/Remove 'In-Progress'
; Only passed when called from Mark/Remove protocol actions
; from the Expand Entry Worklist.
; Optional, defaults to "-1"
; WLIST - Worklist, the user is selecting from. Set to 'IBTRH5IX'
; when called from the response worklist.
; Optional, defaults to 'IBTRH1IX'
; ^TMP($J,"IBTRH1IX") - Index of displayed lines of the HCSR Worklist
; Only used if WLIST is not 'IBTRH5IX"
; ^TMP($J,"IBTRH5IX") - Index of displayed lines of the HCSR Response
; Worklist. Only used if WLIST is 'IBTRH5IX"
; ^TMP("IBTRH1",$J) - Current Array of displayed entries
; ^TMP($J,"IBTRHIX") - Current Index of displayed lines
; Output: Selected Entry is marked in progress or remove marked in progress
; or VALMSG is displayed with an error message
; ^TMP("IBTRH1",$J) - Updated Array of displayed entries
; ^TMP($J,"IBTRHIX") - Updated Index of displayed lines
;
N CSTAT,DIR,DIROUT,DIRUT,DLINE,DTOUT,DUOUT,EIEN,EIENS,ERROR,EVENT,FIELD,FLG
N IX,LINE,PROMPT,REST,STATUS,STATUSDT,STATUSU,XX
S:$G(EIENIN)="" EIENIN=-1
S:'$D(WLIST) WLIST="IBTRH1IX"
S XX=$S(WLIST="IBTRH5IX":1,1:0)
D VALMSGH(XX) ; Set flag legend
S EIENS=$S(EIENIN'=-1:EIENIN,1:"")
S VALMBCK="R"
S ERROR=0
I WHICH=0 S REST=" remove 'In-Progress' mark",STATUS="0",STATUSDT="@",STATUSU="@"
E S REST="Set 'In-Progress' mark",STATUS="01",STATUSDT=DT,STATUSU=DUZ
I WLIST="IBTRH5IX",STATUS="01" S STATUS=1
; First select the entry to be removed from the worklist
S PROMPT="Select the entry(s) to "_REST
S:EIENS="" EIENS=$$SELEVENT(1,PROMPT,.DLINE,1,WLIST) ; Select the entry(s) to update
I EIENS="" S VALMBCK="R" Q
F IX=1:1:$L(EIENS,",") D
. S EIEN=$P(EIENS,",",IX)
. S LINE=$S(EIENIN'=-1:"",1:$P(DLINE,",",IX))
. ; Get the current status of the entry
. S:WLIST="IBTRH5IX" CSTAT=+$$GET1^DIQ(356.22,EIEN_",",.21,"I")
. S:WLIST'="IBTRH5IX" CSTAT=+$$GET1^DIQ(356.22,EIEN_",",.08,"I")
. ; Make sure the entry can be changed to in-progress, quit otherwise
. I (CSTAT'=0),(CSTAT'=1) D Q ; Invalid to be changed
.. W !,*7,">>>> Entry ",LINE," - Invalid Status, action not performed"
.. S ERROR=1
. ; Next update the status to be manually updated
. I '$$LOCKEV(EIEN) D Q
.. W !,*7,">>>> Some else is editing the entry ",LINE,". Try again later."
.. S ERROR=1
. S XX=$S(WLIST="IBTRH5IX":1,1:0)
. D PRMARK1(EIEN,STATUS,STATUSU,STATUSDT,XX)
. D UNLOCKEV(EIEN)
. Q:EIENIN'=-1
. ; Finally, update the line and redisplay it
. S EVENT=^IBT(356.22,EIEN,0)
. I WLIST="IBTRH1IX" D
.. S FLG=$S($P(EVENT,"^",8)="01":"#",1:" ")
.. S LINE=$O(^TMP("IBTRH1",$J,"IDXX",LINE,0))
.. S FIELD=FLG_$E($G(^TMP("IBTRH1",$J,LINE,0)),7,23)
. I WLIST="IBTRH5IX" D
.. S FLG=$S($P(EVENT,"^",21)=1:"#",1:" ")
.. S FIELD=FLG_$E($G(^TMP("IBTRH5",$J,LINE,0)),7,23)
. D FLDTEXT^VALM10(LINE,"PAT NAME",FIELD) ; Update flag display
. D WRITE^VALM10(LINE) ; Redisplay line
K DIR
Q:EIENIN'=-1
D:ERROR PAUSE^VALM1
Q
;
PRMARK1(IEN,STATUS,USER,TSTAMP,RESP) ; Change 'In-Progress' status of a given entry
; Input: IEN - IEN of file 356.22 entry to use
; STATUS - New status to set: '01' - Set 'In-Progress',
; '0' - Remove 'In-Progress'
; USER - File 200 ien of a user changing the status, defaults
; to DUZ
; TSTAMP - Timestamp of the status change, defaults to current
; date/time
; RESP - 1 - Setting field .21 instead of field .08
; Optional, defaults to 0
N IENS,SDATA
Q:'+$G(IEN) ; Invalid ien
S:'$D(RESP) RESP=0
I 'RESP,"^01^0^"'[(U_$G(STATUS)_U) Q ; Invalid status for Main Worklist
I RESP,"^1^0^"'[(U_$G(STATUS)_U) Q ; Invalid status for Response Worklist
S:$G(USER)="" USER=DUZ
S:$G(TSTAMP)="" TSTAMP=$$NOW^XLFDT()
S IENS=+IEN_","
S:'RESP SDATA(356.22,IENS,.08)=STATUS ; Update status
S:RESP SDATA(356.22,IENS,.21)=STATUS ; Update Response Status
S SDATA(356.22,IENS,.09)=USER ; Update status entered by
S SDATA(356.22,IENS,.1)=TSTAMP ; Update status entered date
D FILE^DIE("","SDATA")
Q
;
SELEVENT(FULL,PROMPT,DLINE,MULT,WLIST) ;EP
; Select Entry(s) to perform an action upon
; Input: FULL - 1 - full screen mode, 0 otherwise
; PROMPT - Prompt to be displayed to the user
; MULT - 1 to allow multiple entry selection
; 0 to only allow single entry selection
; Optional, defaults to 0
; WLIST - Worklist, the user is selecting from
; Set to 'IBTRH5IX' when called from the
; response worklist.
; Optional, defaults to 'IBTRH1IX'
; ^TMP($J,"IBTRH1IX") - Index of displayed lines of the HCSR Worklist
; Only used if WLIST is not 'IBTRH5IX"
; ^TMP($J,"IBTRH5IX") - Index of displayed lines of the HCSR Response
; Worklist. Only used if WLIST is 'IBTRH5IX"
; Output: DLINE - Comma delimited list of Line #(s) of the
; selected entries
; Returns: EIN(s) - Comma delimited string or IENS for the selected entry(s)
; Error message and "" IENS if multi-selection and not allowed
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,EIEN,EIENS,IX,VALMY,X,Y
S:'$D(MULT) MULT=0
S:'$D(WLIST) WLIST="IBTRH1IX"
D:FULL FULL^VALM1
S DLINE=$P($P($G(XQORNOD(0)),"^",4),"=",2) ; User selection with action
S DLINE=$TR(DLINE,"/\; .",",,,,,") ; Check for multi-selection
S EIENS=""
I 'MULT,DLINE["," D Q "" ; Invalid multi-selection
. W !,*7,">>>> Only single entry selection is allowed"
. S DLINE=""
. K DIR
. D PAUSE^VALM1
; Check the user enter their selection(s)
D EN^VALM2($G(XQORNOD(0)),"O") ; ListMan generic selector
I '$D(VALMY) Q ""
S IX="",DLINE=""
F D Q:IX=""
. S IX=$O(VALMY(IX))
. Q:IX=""
. S DLINE=$S(DLINE="":IX,1:DLINE_","_IX)
. S EIEN=$G(^TMP($J,WLIST,IX))
. S EIENS=$S(EIENS="":EIEN,1:EIENS_","_EIEN)
Q EIENS
;
ADDCMT ;EP
; Listman Protocol Action to add a comment to a selected entry
; Input: ^TMP("IBTRH1",$J) - Current Array of displayed entries
; ^TMP($J,"IBTRHIX") - Current Index of displayed lines
; Output: Comment is added (Potentially) to the selected entry
N DLINE,IBTRIEN,PROMPT
S VALMBCK="R"
D VALMSGH ; Set flag legend
; First select the entry to add a comment to
S PROMPT="Select the entry to add a comment to"
S IBTRIEN=$$SELEVENT(1,PROMPT,.DLINE) ; Select the entry to add comment to
I IBTRIEN="" S VALMBCK="R" Q
D ADDCMT^IBTRH2(1)
Q
;
LOCKEV(IEN) ;EP
; Locks the specified entry for editing
; Input: IEN - IEN of the entry to locked
; Output: Entry is locked (potentially)
; Returns: 1 - Entry was locked
; 0 - Entry couldn't be locked
L +^IBT(356.22,IEN):1
Q:$T 1
Q 0
;
UNLOCKEV(IEN) ;EP
; Unlocks the specified entry
; Input: IEN - IEN of the entry to be unlocked
; Output: Entry is unlocked
L -^IBT(356.22,IEN)
Q
;
; Input: None
; Output: COM - Array of Comment text to be entered
; Returns: 1 - 1 - Text entered, 0 otherwise
N DIC,DWPK
K ^TMP($J,"COMMENT")
S DWPK=1,DIC="^TMP($J,""COMMENT"","
D EN^DIWE
Q:'$D(^TMP($J,"COMMENT")) 0
M COM=^TMP($J,"COMMENT")
K ^TMP($J,"COMMENT")
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRH1 19715 printed Oct 16, 2024@18:28:35 Page 2
IBTRH1 ;ALB/FA - HCSR Worklist ;01-JUL-2014
+1 ;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;
+4 ;
EN ;EP
+1 ; Main entry point for HCSR Worklist
+2 ; Input: None
+3 NEW HCSRSORT,IBFILTS
+4 ; Returns an array of filter settings
if '$$FILTERS^IBTRH1A(.IBFILTS)
QUIT
+5 ; Sort the entries
DO SORT(1)
+6 DO EN^VALM("IBT HCSR WORKLIST")
+7 QUIT
+8 ;
HDR ;EP
+1 ; Header code for HCSR Worklist
+2 ; Input: HCSRSORT - Current sort selection
+3 ; IBFILTS() - Array of filter criteria
+4 ; Output: VALMHDR - Header information to display
+5 ; VALM("TITLE") - HCSR Worklist Title
+6 ; VALMSG - Initial Error line display
+7 NEW XX
+8 if $GET(HCSRSORT)=""
SET HCSRSORT="1^Oldest Entries First"
+9 SET VALMHDR(1)=$$FILTBY(.IBFILTS)
+10 SET VALMHDR(2)="Sorted By: "_$PIECE(HCSRSORT,"^",2)
+11 SET VALM("TITLE")="HCSR Worklist"
+12 ; Set flag legend
DO VALMSGH
+13 QUIT
+14 ;
VALMSGH(INP) ;EP
+1 ; Sets the legend into variable VALMSG
+2 ; Input: INP - 1 - Only display #In-Prog, 0 - Display all
+3 ; Optional, defaults to 0
+4 ; Output: VALMSG is set
+5 if '$DATA(INP)
SET INP=0
+6 IF INP
SET VALMSG="#In-Prog"
QUIT
+7 SET VALMSG="?Await #In-Prog -RespErr !Unable +Pend *NextRev"
+8 QUIT
+9 ;
FILTBY(IBFILTS) ;EP
+1 ; Creates the 'Filtered By' line of the worklist header
+2 ; Input: IBFILT - Array of current filter settings
+3 ; Returns: Filtered By line
+4 NEW XX
+5 IF $PIECE(IBFILTS(0),"^",2)=0
SET XX="CPAC, "
+6 IF $PIECE(IBFILTS(0),"^",2)=1
SET XX="CHAMPVA/TRICARE, "
+7 IF $PIECE(IBFILTS(0),"^",2)=2
SET XX="Both CPAC and CHAMPVA/TRICARE, "
+8 SET XX=XX_$SELECT($GET(IBFILTS(3))'="":"Sel Div, ",1:"All Div, ")
+9 IF $PIECE(IBFILTS(0),"^",1)=0
Begin DoDot:1
+10 SET XX=XX_$SELECT($GET(IBFILTS(1))'="":"Sel Outpt",1:"All Outpt")
End DoDot:1
+11 IF $PIECE(IBFILTS(0),"^",1)=1
Begin DoDot:1
+12 SET XX=XX_$SELECT($GET(IBFILTS(2))'="":"Sel Inpt",1:"All Inpt")
End DoDot:1
+13 IF $PIECE(IBFILTS(0),"^",1)=2
Begin DoDot:1
+14 SET XX=XX_$SELECT($GET(IBFILTS(1))'="":"Sel Outpt, ",1:"All Outpt, ")
+15 SET XX=XX_$SELECT($GET(IBFILTS(2))'="":"Sel Inpt",1:"All Inpt")
End DoDot:1
+16 QUIT "Filtered By: "_XX
+17 ;
INIT ;EP
+1 ; Initialize variables and list array
+2 ; Input: None
+3 ; Output: HCSRSORT - Initial worklist sort if not yet defined
+4 ; IBFILTS() - Array of filter criteria
+5 ; ^TMP("IBTRH1",$J) - Body lines to display
+6 KILL ^TMP("IBTRH1",$JOB),^TMP($JOB,"IBTRH1IX")
+7 if $GET(HCSRSORT)=""
SET HCSRSORT="1^Oldest Entries First"
+8 DO BLD
+9 QUIT
+10 ;
BLD ; Build screen array, no variables required for input
+1 ; Input: HCSRSORT - Current select sort type
+2 ; IBFILTS() - Array of filter criteria
+3 ; Output: ^TMP("IBTRH1",$J) - Body lines to display
+4 ; ^TMP($J,"IBTRH1S") - Sorted Body lines to display
+5 ; ^TMP($J,"IBTRH1IX") - Index of Entry IENs by display line
+6 NEW DA,ECTR,LINE,S1,S2,S3,XSELCNT,XDA1,XRESP,XREJDA,XREJDA1
+7 ; Build the sorted list of lines to display
+8 DO SORT1^IBTRH1A
+9 SET (ECTR,VALMCNT)=0
SET S1=""
+10 FOR
SET S1=$ORDER(^TMP($JOB,"IBTRH1S",S1))
if S1=""
QUIT
Begin DoDot:1
+11 SET S2=""
FOR
SET S2=$ORDER(^TMP($JOB,"IBTRH1S",S1,S2))
if S2=""
QUIT
Begin DoDot:2
+12 SET S3=""
FOR
SET S3=$ORDER(^TMP($JOB,"IBTRH1S",S1,S2,S3))
if S3=""
QUIT
Begin DoDot:3
+13 SET DA=""
FOR
SET DA=$ORDER(^TMP($JOB,"IBTRH1S",S1,S2,S3,DA))
if DA=""
QUIT
Begin DoDot:4
+14 SET ECTR=ECTR+1
+15 SET LINE=^TMP($JOB,"IBTRH1S",S1,S2,S3,DA)
+16 SET LINE=$$BLDLN(ECTR,LINE)
+17 SET VALMCNT=VALMCNT+1
SET XSELCNT=$GET(XSELCNT)+1
+18 DO SET^VALM10(VALMCNT,LINE,XSELCNT)
DO BLD1
+19 SET ^TMP($JOB,"IBTRH1IX",XSELCNT)=DA
+20 SET XRESP=$PIECE(^IBT(356.22,DA,0),U,14)
+21 IF XRESP'=""
SET XDA1=$GET(^IBT(356.22,XRESP,103))
+22 IF $PIECE($GET(XDA1),U,3)'=""
Begin DoDot:5
+23 NEW XREVDA1
+24 DO GETS^DIQ(356.021,$PIECE(XDA1,U,3),".01:.02",,"XREVDA1")
+25 SET VALMCNT=VALMCNT+1
+26 DO SET^VALM10(VALMCNT," Review Decision: "_XREVDA1(356.021,$PIECE(XDA1,U,3)_",",".01")_" - "_XREVDA1(356.021,$PIECE(XDA1,U,3)_",",".02"),XSELCNT)
+27 DO BLD1
End DoDot:5
+28 IF XRESP'=""
SET XDA1=0
FOR
SET XDA1=$ORDER(^IBT(356.22,XRESP,101,XDA1))
if 'XDA1
QUIT
Begin DoDot:5
+29 SET XREJDA=+$PIECE($GET(^IBT(356.22,XRESP,101,XDA1,0)),U,4)
IF 'XREJDA
QUIT
+30 DO GETS^DIQ(365.017,XREJDA,".01:.02",,"XREJDA1")
+31 SET VALMCNT=VALMCNT+1
+32 DO SET^VALM10(VALMCNT," Rejection: "_XREJDA1(365.017,XREJDA_",",".01")_" - "_XREJDA1(365.017,XREJDA_",",".02"),XSELCNT)
+33 DO BLD1
+34 SET XDA1=""
+35 QUIT
End DoDot:5
+36 QUIT
End DoDot:4
+37 QUIT
End DoDot:3
+38 QUIT
End DoDot:2
+39 QUIT
End DoDot:1
+40 IF VALMCNT=0
Begin DoDot:1
+41 SET ^TMP("IBTRH1",$JOB,1,0)="There are no entries to display."
End DoDot:1
+42 QUIT
+43 ;
BLD1 ;
+1 SET ^TMP("IBTRH1",$JOB,"IDXX",XSELCNT,VALMCNT)=""
+2 QUIT
+3 ;
BLDLN(ECTR,LINED) ; Builds a line to display on List screen for one entry
+1 ; Input: ECTR - Entry counter
+2 ; LINED - A1^A2^...A9 Where:
+3 ; A1 - Patient Name
+4 ; A2 - Patient Status ('I' or 'O')
+5 ; A3 - External Appt or Admission date
+6 ; A4 - Clinic or Ward name
+7 ; A5 - COB ('P' or 'S')
+8 ; A6 - Insurance Company Name
+9 ; A7 - Utilization Review required
+10 ; A8 - Pre-Certification required
+11 ; A9 - Service Connection flags
+12 ; Output: LINE - Formatted for setting into the list display
+13 NEW LINE,LINEI
+14 ; Entry #
SET LINE=$$SETSTR^VALM1(ECTR,"",1,4)
+15 ; Patient Name
SET LINE=$$SETSTR^VALM1($PIECE(LINED,"^",1),LINE,6,23)
+16 ; Patient Status
SET LINE=$$SETSTR^VALM1($PIECE(LINED,"^",2),LINE,30,1)
+17 ; Appt/Adm Date
SET LINE=$$SETSTR^VALM1($PIECE(LINED,"^",3),LINE,32,8)
+18 ; Clinic or Ward
SET LINE=$$SETSTR^VALM1($PIECE(LINED,"^",4),LINE,41,10)
+19 ; COB
SET LINE=$$SETSTR^VALM1($PIECE(LINED,"^",5),LINE,52,1)
+20 ; Insurance Name
SET LINE=$$SETSTR^VALM1($PIECE(LINED,"^",6),LINE,55,14)
+21 ; UR required
SET LINE=$$SETSTR^VALM1($PIECE(LINED,"^",7),LINE,70,1)
+22 ; Pre-Cert Required
SET LINE=$$SETSTR^VALM1($PIECE(LINED,"^",8),LINE,72,1)
+23 ; Service Connections
SET LINE=$$SETSTR^VALM1($PIECE(LINED,"^",9),LINE,74,5)
+24 QUIT LINE
+25 ;
HELP ;EP
+1 ; Help code
+2 ; Input: None
+3 DO FULL^VALM1
+4 SET VALMBCK="R"
+5 WRITE @IOF,"Flags displayed on screen for SC Reas (Service Connected Reason):"
+6 WRITE !," A - Agent Orange"
+7 WRITE !," I - Ionizing Radiation"
+8 WRITE !," S - Southwest Asia"
+9 WRITE !," N - Nose/Throat Radium"
+10 WRITE !," C - Combat Veteran"
+11 WRITE !," M - Military Sexual Trauma (MST)"
+12 WRITE !," L - Camp Lejeune"
+13 WRITE !,"Flags displayed on screen for U (UR Required) or P (Pre-certification Required):"
+14 WRITE !," Y - Yes, N - No"
+15 WRITE !,"Flags displayed on screen for S (Patient Status):"
+16 WRITE !," O - Outpatient, I - Inpatient"
+17 WRITE !,"The following Status indicators may appear to the left of the patient name:"
+18 WRITE !," # - 278 has been not been initiated, entry is in-progress"
+19 WRITE !," ? - 278 has been sent and waiting for response"
+20 WRITE !," + - 278 is pending"
+21 WRITE !," * - Flagged for Next Review"
+22 WRITE !," ! - Unable to send 278"
+23 WRITE !," <Blank> - Entry added through scheduled task"
+24 WRITE !," - - 278 has been sent and negative response received "
+25 WRITE !," (error AAA condition in AAA segment(s))"
+26 SET VALMSG="?Await #In-Prog -RespErr !Unable +Pend *NextRev"
+27 QUIT
+28 ;
EXIT ;EP
+1 ; Exit code
+2 ; Input: None
+3 KILL ^TMP("IBTRH1",$JOB),^TMP($JOB,"IBTRH1IX"),^TMP($JOB,"IBTRH1S")
+4 KILL HCSRSORT
+5 DO CLEAR^VALM1
+6 QUIT
+7 ;
SORT(FIRST) ;EP
+1 ; Listman Protocol Action to sort the worklist
+2 ; Input: FIRST - 1 - Called for the first time before the Worklist is displayed
+3 ; 2 - Called from Refresh action (REFRESH^IBTRH1A)
+4 ; 0 - Called as an action from within the Worklist, Optional, defaults to 0
+5 ; HCSRSORT - Current sort selection (null if FIRST=1)
+6 ; IBFILTS()- Array of filter criteria
+7 ; Output: HCSRSORT - New sort selection and list is sorted
+8 NEW CTR,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ST,STDES,X,XX,Y
+9 ; Set flag legend
DO VALMSGH
+10 SET CTR=1
+11 if '$DATA(FIRST)
SET FIRST=0
+12 if FIRST=1
SET HCSRSORT="1^Oldest Entries First"
+13 IF 'FIRST!(FIRST=2)
Begin DoDot:1
+14 if 'FIRST
DO FULL^VALM1
+15 if 'FIRST
WRITE @IOF
+16 WRITE !,"Select the item to sort the records on the HCSR Worklist screen."
End DoDot:1
+17 SET XX="SO^"_CTR_":Oldest Entries First"
SET CTR=CTR+1
+18 SET XX=XX_";"_CTR_":Newest Entries First"
SET CTR=CTR+1
+19 if +IBFILTS(0)=2
SET XX=XX_";"_CTR_":Outpatient Appointments First"
SET CTR=CTR+1
+20 if +IBFILTS(0)=2
SET XX=XX_";"_CTR_":Inpatient Admissions First"
SET CTR=CTR+1
+21 SET XX=XX_";"_CTR_":Insurance Company Name"
+22 SET DIR(0)=XX
+23 SET DIR("A")="Sort the list by"
SET DIR("B")=$PIECE($GET(HCSRSORT),"^",2)
+24 DO ^DIR
KILL DIR
+25 ; User quit or timed out
IF 'Y
SET VALMBCK="R"
QUIT
+26 SET XX=$SELECT(+IBFILTS(0)=2:Y,Y<3:Y,1:5)
+27 ; Sort selection
SET HCSRSORT=XX_"^"_Y(0)
+28 if FIRST
QUIT
+29 ; Rebuild and resort the list and update the list header
+30 DO INIT
DO HDR
+31 SET VALMBCK="R"
SET VALMBG=1
+32 QUIT
+33 ;
DEL ;EP
+1 ; Protocol Action to select an entry to be manually removed from the worklist
+2 ; Input: ^TMP("IBTRH1",$J) - Current Array of displayed entries
+3 ; ^TMP($J,"IBTRHIX") - Current Index of displayed entries
+4 ; Output: Selected Entry is removed from the worklist
+5 ; Error messages display (potentially)
+6 ; ^TMP("IBTRH1",$J) - Updated Array of displayed entries
+7 ; ^TMP($J,"IBTRHIX") - Updated Index of displayed entries
+8 NEW DIR,DIROUT,DIRUT,DLINE,DTOUT,DUOUT,EIEN,EIENS,ERROR,IEN,IX,LINE,MSG
+9 NEW PROMPT,SDATA,DELRCODE,XCOM,COM,DIWETXT
+10 ; Set flag legend
DO VALMSGH
+11 SET VALMBCK="R"
SET ERROR=0
+12 ; First select the entry(s) to be removed from the worklist
+13 SET PROMPT="Select the worklist entry(s) to be deleted"
+14 SET MSG="Are you sure you want to delete "
+15 ; Select the entry to be deleted
SET EIENS=$$SELEVENT(1,PROMPT,.DLINE,1)
+16 IF EIENS=""
SET VALMBCK="R"
QUIT
D1 ;
+1 SET DIC(0)="AEQM"
SET DIC="^IBT(356.023,"
+2 SET DIC("A")="Select a Delete Reason Code: "
+3 DO ^DIC
+4 IF Y<0
if X="^"
QUIT
WRITE !,*7,">>>> A Delete Reason Code must be selected, or '^' to exit."
GOTO D1
+5 SET DELRCODE=$PIECE(Y,"^")
+6 ; Final warning
if '$$ASKSURE(DLINE,MSG)
QUIT
+7 FOR IX=1:1:$LENGTH(EIENS,",")
Begin DoDot:1
+8 SET EIEN=$PIECE(EIENS,",",IX)
+9 SET LINE=$PIECE(DLINE,",",IX)
+10 ; Don't allow deletion of entries with a pending response (status '02')
+11 IF +$PIECE(^IBT(356.22,EIEN,0),"^",8)=2
Begin DoDot:2
+12 WRITE !,*7,">>>> Entry ",LINE," has been sent and is awaiting a response. It cannot be deleted."
+13 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+14 SET DIR(0)="EA"
+15 SET DIR("A",1)=" "
+16 SET DIR("A")="Press RETURN to continue "
DO ^DIR
+17 SET ERROR=1
+18 QUIT
End DoDot:2
QUIT
+19 ; Next update the status to be manually removed
+20 IF '$$LOCKEV(EIEN)
Begin DoDot:2
+21 WRITE !,*7,">>>> Someone else is editing entry ",LINE,". Try again later."
+22 SET ERROR=1
End DoDot:2
QUIT
+23 KILL SDATA
+24 SET IEN=EIEN_","
+25 ; Set Status manual remove flag
SET SDATA(356.22,IEN,.08)="06"
+26 ; Set Manually Removed Date/Time
SET SDATA(356.22,IEN,.23)=$$NOW^XLFDT()
+27 ; Set Manually Removed By User
SET SDATA(356.22,IEN,.24)=DUZ
+28 ; Set Delete Reason code pointer
SET SDATA(356.22,IEN,.25)=DELRCODE
+29 ; 517-T14: if REQUESTED BY is blank, set it to user deleting
IF $PIECE(^IBT(356.22,EIEN,0),"^",11)=""
SET SDATA(356.22,IEN,.11)=DUZ
+30 DO FILE^DIE("","SDATA")
+31 DO UNLOCKEV(EIEN)
End DoDot:1
if $GET(ERROR)
QUIT
+32 IF $GET(ERROR)
QUIT
+33 KILL DIR
+34 QUIT
+35 ;
ASKSURE(DLINE,MSG,ENTIRE) ;EP
+1 ; Make sure the user wants to proceed with the selected action
+2 ; Input: DLINE - Comma delimited list of valid selected lines
+3 ; MSG - Message to be displayed to the user
+4 ; ENTIRE - 1 - MSG is the entire prompt do not append
+5 ; 0 - MSG is not the entire prompt append
+6 ; Optional, defaults to 0
+7 ; Returns: 1 - Proceed with action, 0 otherwise
+8 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XX,Y
+9 if '$DATA(ENTIRE)
SET ENTIRE=0
+10 SET XX=$SELECT(DLINE[",":"entries ",1:"entry ")
+11 SET DIR(0)="YO"
SET DIR("B")="N"
+12 if 'ENTIRE
SET MSG=MSG_XX_DLINE
+13 SET DIR("A")=MSG
+14 DO ^DIR
KILL DIR
+15 if 'Y
QUIT 0
+16 QUIT 1
+17 ;
PRMARK(WHICH,EIENIN,WLIST) ;EP
+1 ; Listman Protocol Action to Mark/Remove 'In-Progress' from a selected entry
+2 ; Called from HSCR Worklist and HSCR Response Worklist
+3 ; Input: WHICH - 0 - Remove 'In-Progress' mark
+4 ; 1 - Set 'In-Progress' mark
+5 ; EIENIN - IEN of the entry to Mark/Remove 'In-Progress'
+6 ; Only passed when called from Mark/Remove protocol actions
+7 ; from the Expand Entry Worklist.
+8 ; Optional, defaults to "-1"
+9 ; WLIST - Worklist, the user is selecting from. Set to 'IBTRH5IX'
+10 ; when called from the response worklist.
+11 ; Optional, defaults to 'IBTRH1IX'
+12 ; ^TMP($J,"IBTRH1IX") - Index of displayed lines of the HCSR Worklist
+13 ; Only used if WLIST is not 'IBTRH5IX"
+14 ; ^TMP($J,"IBTRH5IX") - Index of displayed lines of the HCSR Response
+15 ; Worklist. Only used if WLIST is 'IBTRH5IX"
+16 ; ^TMP("IBTRH1",$J) - Current Array of displayed entries
+17 ; ^TMP($J,"IBTRHIX") - Current Index of displayed lines
+18 ; Output: Selected Entry is marked in progress or remove marked in progress
+19 ; or VALMSG is displayed with an error message
+20 ; ^TMP("IBTRH1",$J) - Updated Array of displayed entries
+21 ; ^TMP($J,"IBTRHIX") - Updated Index of displayed lines
+22 ;
+23 NEW CSTAT,DIR,DIROUT,DIRUT,DLINE,DTOUT,DUOUT,EIEN,EIENS,ERROR,EVENT,FIELD,FLG
+24 NEW IX,LINE,PROMPT,REST,STATUS,STATUSDT,STATUSU,XX
+25 if $GET(EIENIN)=""
SET EIENIN=-1
+26 if '$DATA(WLIST)
SET WLIST="IBTRH1IX"
+27 SET XX=$SELECT(WLIST="IBTRH5IX":1,1:0)
+28 ; Set flag legend
DO VALMSGH(XX)
+29 SET EIENS=$SELECT(EIENIN'=-1:EIENIN,1:"")
+30 SET VALMBCK="R"
+31 SET ERROR=0
+32 IF WHICH=0
SET REST=" remove 'In-Progress' mark"
SET STATUS="0"
SET STATUSDT="@"
SET STATUSU="@"
+33 IF '$TEST
SET REST="Set 'In-Progress' mark"
SET STATUS="01"
SET STATUSDT=DT
SET STATUSU=DUZ
+34 IF WLIST="IBTRH5IX"
IF STATUS="01"
SET STATUS=1
+35 ; First select the entry to be removed from the worklist
+36 SET PROMPT="Select the entry(s) to "_REST
+37 ; Select the entry(s) to update
if EIENS=""
SET EIENS=$$SELEVENT(1,PROMPT,.DLINE,1,WLIST)
+38 IF EIENS=""
SET VALMBCK="R"
QUIT
+39 FOR IX=1:1:$LENGTH(EIENS,",")
Begin DoDot:1
+40 SET EIEN=$PIECE(EIENS,",",IX)
+41 SET LINE=$SELECT(EIENIN'=-1:"",1:$PIECE(DLINE,",",IX))
+42 ; Get the current status of the entry
+43 if WLIST="IBTRH5IX"
SET CSTAT=+$$GET1^DIQ(356.22,EIEN_",",.21,"I")
+44 if WLIST'="IBTRH5IX"
SET CSTAT=+$$GET1^DIQ(356.22,EIEN_",",.08,"I")
+45 ; Make sure the entry can be changed to in-progress, quit otherwise
+46 ; Invalid to be changed
IF (CSTAT'=0)
IF (CSTAT'=1)
Begin DoDot:2
+47 WRITE !,*7,">>>> Entry ",LINE," - Invalid Status, action not performed"
+48 SET ERROR=1
End DoDot:2
QUIT
+49 ; Next update the status to be manually updated
+50 IF '$$LOCKEV(EIEN)
Begin DoDot:2
+51 WRITE !,*7,">>>> Some else is editing the entry ",LINE,". Try again later."
+52 SET ERROR=1
End DoDot:2
QUIT
+53 SET XX=$SELECT(WLIST="IBTRH5IX":1,1:0)
+54 DO PRMARK1(EIEN,STATUS,STATUSU,STATUSDT,XX)
+55 DO UNLOCKEV(EIEN)
+56 if EIENIN'=-1
QUIT
+57 ; Finally, update the line and redisplay it
+58 SET EVENT=^IBT(356.22,EIEN,0)
+59 IF WLIST="IBTRH1IX"
Begin DoDot:2
+60 SET FLG=$SELECT($PIECE(EVENT,"^",8)="01":"#",1:" ")
+61 SET LINE=$ORDER(^TMP("IBTRH1",$JOB,"IDXX",LINE,0))
+62 SET FIELD=FLG_$EXTRACT($GET(^TMP("IBTRH1",$JOB,LINE,0)),7,23)
End DoDot:2
+63 IF WLIST="IBTRH5IX"
Begin DoDot:2
+64 SET FLG=$SELECT($PIECE(EVENT,"^",21)=1:"#",1:" ")
+65 SET FIELD=FLG_$EXTRACT($GET(^TMP("IBTRH5",$JOB,LINE,0)),7,23)
End DoDot:2
+66 ; Update flag display
DO FLDTEXT^VALM10(LINE,"PAT NAME",FIELD)
+67 ; Redisplay line
DO WRITE^VALM10(LINE)
End DoDot:1
+68 KILL DIR
+69 if EIENIN'=-1
QUIT
+70 if ERROR
DO PAUSE^VALM1
+71 QUIT
+72 ;
PRMARK1(IEN,STATUS,USER,TSTAMP,RESP) ; Change 'In-Progress' status of a given entry
+1 ; Input: IEN - IEN of file 356.22 entry to use
+2 ; STATUS - New status to set: '01' - Set 'In-Progress',
+3 ; '0' - Remove 'In-Progress'
+4 ; USER - File 200 ien of a user changing the status, defaults
+5 ; to DUZ
+6 ; TSTAMP - Timestamp of the status change, defaults to current
+7 ; date/time
+8 ; RESP - 1 - Setting field .21 instead of field .08
+9 ; Optional, defaults to 0
+10 NEW IENS,SDATA
+11 ; Invalid ien
if '+$GET(IEN)
QUIT
+12 if '$DATA(RESP)
SET RESP=0
+13 ; Invalid status for Main Worklist
IF 'RESP
IF "^01^0^"'[(U_$GET(STATUS)_U)
QUIT
+14 ; Invalid status for Response Worklist
IF RESP
IF "^1^0^"'[(U_$GET(STATUS)_U)
QUIT
+15 if $GET(USER)=""
SET USER=DUZ
+16 if $GET(TSTAMP)=""
SET TSTAMP=$$NOW^XLFDT()
+17 SET IENS=+IEN_","
+18 ; Update status
if 'RESP
SET SDATA(356.22,IENS,.08)=STATUS
+19 ; Update Response Status
if RESP
SET SDATA(356.22,IENS,.21)=STATUS
+20 ; Update status entered by
SET SDATA(356.22,IENS,.09)=USER
+21 ; Update status entered date
SET SDATA(356.22,IENS,.1)=TSTAMP
+22 DO FILE^DIE("","SDATA")
+23 QUIT
+24 ;
SELEVENT(FULL,PROMPT,DLINE,MULT,WLIST) ;EP
+1 ; Select Entry(s) to perform an action upon
+2 ; Input: FULL - 1 - full screen mode, 0 otherwise
+3 ; PROMPT - Prompt to be displayed to the user
+4 ; MULT - 1 to allow multiple entry selection
+5 ; 0 to only allow single entry selection
+6 ; Optional, defaults to 0
+7 ; WLIST - Worklist, the user is selecting from
+8 ; Set to 'IBTRH5IX' when called from the
+9 ; response worklist.
+10 ; Optional, defaults to 'IBTRH1IX'
+11 ; ^TMP($J,"IBTRH1IX") - Index of displayed lines of the HCSR Worklist
+12 ; Only used if WLIST is not 'IBTRH5IX"
+13 ; ^TMP($J,"IBTRH5IX") - Index of displayed lines of the HCSR Response
+14 ; Worklist. Only used if WLIST is 'IBTRH5IX"
+15 ; Output: DLINE - Comma delimited list of Line #(s) of the
+16 ; selected entries
+17 ; Returns: EIN(s) - Comma delimited string or IENS for the selected entry(s)
+18 ; Error message and "" IENS if multi-selection and not allowed
+19 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,EIEN,EIENS,IX,VALMY,X,Y
+20 if '$DATA(MULT)
SET MULT=0
+21 if '$DATA(WLIST)
SET WLIST="IBTRH1IX"
+22 if FULL
DO FULL^VALM1
+23 ; User selection with action
SET DLINE=$PIECE($PIECE($GET(XQORNOD(0)),"^",4),"=",2)
+24 ; Check for multi-selection
SET DLINE=$TRANSLATE(DLINE,"/\; .",",,,,,")
+25 SET EIENS=""
+26 ; Invalid multi-selection
IF 'MULT
IF DLINE[","
Begin DoDot:1
+27 WRITE !,*7,">>>> Only single entry selection is allowed"
+28 SET DLINE=""
+29 KILL DIR
+30 DO PAUSE^VALM1
End DoDot:1
QUIT ""
+31 ; Check the user enter their selection(s)
+32 ; ListMan generic selector
DO EN^VALM2($GET(XQORNOD(0)),"O")
+33 IF '$DATA(VALMY)
QUIT ""
+34 SET IX=""
SET DLINE=""
+35 FOR
Begin DoDot:1
+36 SET IX=$ORDER(VALMY(IX))
+37 if IX=""
QUIT
+38 SET DLINE=$SELECT(DLINE="":IX,1:DLINE_","_IX)
+39 SET EIEN=$GET(^TMP($JOB,WLIST,IX))
+40 SET EIENS=$SELECT(EIENS="":EIEN,1:EIENS_","_EIEN)
End DoDot:1
if IX=""
QUIT
+41 QUIT EIENS
+42 ;
ADDCMT ;EP
+1 ; Listman Protocol Action to add a comment to a selected entry
+2 ; Input: ^TMP("IBTRH1",$J) - Current Array of displayed entries
+3 ; ^TMP($J,"IBTRHIX") - Current Index of displayed lines
+4 ; Output: Comment is added (Potentially) to the selected entry
+5 NEW DLINE,IBTRIEN,PROMPT
+6 SET VALMBCK="R"
+7 ; Set flag legend
DO VALMSGH
+8 ; First select the entry to add a comment to
+9 SET PROMPT="Select the entry to add a comment to"
+10 ; Select the entry to add comment to
SET IBTRIEN=$$SELEVENT(1,PROMPT,.DLINE)
+11 IF IBTRIEN=""
SET VALMBCK="R"
QUIT
+12 DO ADDCMT^IBTRH2(1)
+13 QUIT
+14 ;
LOCKEV(IEN) ;EP
+1 ; Locks the specified entry for editing
+2 ; Input: IEN - IEN of the entry to locked
+3 ; Output: Entry is locked (potentially)
+4 ; Returns: 1 - Entry was locked
+5 ; 0 - Entry couldn't be locked
+6 LOCK +^IBT(356.22,IEN):1
+7 if $TEST
QUIT 1
+8 QUIT 0
+9 ;
UNLOCKEV(IEN) ;EP
+1 ; Unlocks the specified entry
+2 ; Input: IEN - IEN of the entry to be unlocked
+3 ; Output: Entry is unlocked
+4 LOCK -^IBT(356.22,IEN)
+5 QUIT
+6 ;
+1 ; Input: None
+2 ; Output: COM - Array of Comment text to be entered
+3 ; Returns: 1 - 1 - Text entered, 0 otherwise
+4 NEW DIC,DWPK
+5 KILL ^TMP($JOB,"COMMENT")
+6 SET DWPK=1
SET DIC="^TMP($J,""COMMENT"","
+7 DO EN^DIWE
+8 if '$DATA(^TMP($JOB,"COMMENT"))
QUIT 0
+9 MERGE COM=^TMP($JOB,"COMMENT")
+10 KILL ^TMP($JOB,"COMMENT")
+11 QUIT 1
