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

IBTRH1.m

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