- 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 Dec 13, 2024@02:27:58 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