IBTREC ;BAH/MBS - Claims Tracking Comment Editor ; Nov 04, 2024@13:01
;;2.0;INTEGRATED BILLING;**796**;21-MAR-94;Build 34
;Per VA Directive 6402, this routine should not be modified.
Q
EN(CTIEN,DFN) ; -- main entry point for IBT CLAIMS TRACKING CMT EDITOR
;K VALMQUIT
N DIR,X,Y,IBROTH,IBRGENS,IBOKAY,IBREENT,IBRNB
S (IBROTH,IBRGENS,IBOKAY,IBREENT,IBUP)=0
I +$G(CTIEN)'>0 D Q
. W !!,*7,"Claims Tracking record is not identified."
. D PAUSE^VALM1
I +$G(DFN)'>0 D
. S DFN=$P($G(^IBT(356,CTIEN,0)),U,2)
S IBRNB=$$GET1^DIQ(356,CTIEN_",",.19,"I")
I $O(^IBE(356.8,"B","GLOBAL SURGERY",0))=+$G(IBRNB) D Q:+$G(IBUP)
. N IBX,IENS,IBFDA,%DT,X,Y
. S IBRGENS=1
. W !!," For the RNB of GLOBAL SURGERY, enter the related Surgery Date"
. ;S %DT("A")=" Enter Surgery Date: ",%DT="AEX" D ^%DT S IBX=+Y,IBUP=$S(Y="^":1,1:0)
. S DIR(0)="DAO^::EX",DIR("A")=" Enter Surgery Date: "
. S DIR("?")="A 2-digit year means no more than 20 years in the future, or 80 years in the past."
. S DIR("?",1)="Examples of Valid Dates:"
. S DIR("?",2)=" JAN 20 1957 or 20 JAN 57 or 1/20/57 or 012057 (omitting punctuation)"
. S DIR("?",3)=" T (for TODAY), T+1 (for TOMORROW), T+2, T+7, etc."
. S DIR("?",4)=" T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc."
. S DIR("?",5)="If the year is omitted, the computer uses CURRENT YEAR."
. D ^DIR
. S IBX=+Y,IBUP=+$G(DUOUT) Q:IBUP
. Q:IBX'?7N
. S IBX="Global Surgery: "_$$FMTE^XLFDT(IBX,2),IBX=$E(IBX,1,80)
. S IENS="+1,"_CTIEN_","
. S IBFDA(356.04,IENS,.01)=DT ; Date is today
. S IBFDA(356.04,IENS,.02)=DUZ ; User is current user
. S IBFDA(356.04,IENS,1)=IBX ; Comment is Comment
. D UPDATE^DIE(,"IBFDA")
I $O(^IBE(356.8,"B","OTHER",0))=+$G(IBRNB) D
. S IBROTH=1
. W !,"The RNB of OTHER requires a Comment of at least 15 characters"
F D Q:IBOKAY!IBUP
. S IBOKAY=1
. I 'IBREENT S DIR(0)="Y",DIR("A")=" ADDITIONAL COMMENTS: ",DIR("B")="Y" D ^DIR
. I $D(DUOUT) S IBUP=1 Q
. I Y!(IBREENT) S IBREENT=1,IBFASTXT=0 D EN^VALM("IBT CLAIMS TRACKING CMT EDITOR")
. I IBROTH D
. . S (I,IBOKAY)=0 F S I=$O(^IBT(356,CTIEN,4,I)) Q:'+I D Q:IBOKAY
. . . I $L($P($G(^IBT(356,CTIEN,4,I,1)),U))>14 S IBOKAY=1
. . I 'IBOKAY D
. . . W !,"The RNB of OTHER requires a Comment of at least 15 characters.",!,"No comment currently satisfies this requirement."
. . . I IBREENT K DIR D PAUSE^VALM1
W:IBREENT !!!
Q
;
HDR ; -- header code
D PID^VADPT N IBXR
;S VALMHDR(1)="Claims Tracking Entries for: "_$E($P($G(^DPT(DFN,0)),"^"),1,20)_" "_$E($G(^(0)),1)_VA("BID")
S XX=$E($P(^DPT(DFN,0),"^",1),1,20)_" "_$P($$PT^IBEFUNC(DFN),"^",2)
S ZZ=$$GET1^DIQ(2,DFN_",",.03),XX=XX_" "_ZZ
S VALMHDR(1)="RNB Comment History for: "_XX
S VALMHDR(2)="For "_$$GET1^DIQ(356,CTIEN_",",.18)_" on: "_$$GET1^DIQ(356,CTIEN_",",.06)
Q
;
INIT ; -- init variables and list array
K ^TMP($J,"IBTREC"),^TMP($J,"IBTRECEX")
D BLD
Q
;
BLD ; -- Build list of comments
N CNT,LINE,LN,XX
D GETCMTS(CTIEN)
S VALMCNT=0,LINE="",CNT=""
;
S CNT=0 F S CNT=$O(^TMP($J,"IBTRECEX",CNT)) Q:'+CNT D
. I CNT'=1 D ; Set an empty line between records
. . S VALMCNT=VALMCNT+1
. . D SET^VALM10(VALMCNT,"",VALMCNT)
. ;
. S VALMCNT=VALMCNT+1
. D BLDONEC(.VALMCNT,CNT)
;
I VALMCNT=0 D
. S VALMCNT=1,XX=" *** No comments to display ***"
. D SET^VALM10(VALMCNT,XX,VALMCNT)
I $G(IBROTH) S VALMSG="RNB of OTHER requires Comment of at least 15 chars"
Q
;
BLDONEC(VALMCNT,COMCNT) ; -- Build one item
N DATALN,I,IBTMP,LINE
S LINE=$$SETL("",COMCNT,"",1,4) ; Comment #
S DATALN=^TMP($J,"IBTRECEX",COMCNT)
S XX=$P(DATALN,"^",1) ; Dt Entered
S LINE=$$SETL(LINE,XX,"",6,12)
D SET^VALM10(VALMCNT,LINE,VALMCNT)
S XX=$P(DATALN,"^",2) ; Entered By
S LINE=$$SETL(LINE,XX,"",19,40)
D SET^VALM10(VALMCNT,LINE,VALMCNT)
S XX=$P(DATALN,"^",3) ; Department
S LINE=$$SETL(LINE,XX,"",62,17)
D SET^VALM10(VALMCNT,LINE,VALMCNT)
;S XX=$E($P(DATALN,"^",5),1,80) ; Start of Comment
S XX=$P(DATALN,"^",5)
D WRAP(XX,80)
S I=0 F S I=$O(IBTMP(I)) Q:'+I D
. S VALMCNT=VALMCNT+1
. D SET^VALM10(VALMCNT,IBTMP(I),VALMCNT)
;F I=1:80:$L(XX) D
;S I=1 F D Q:I'<$L(XX)
;. N X,LEN
;. S LEN=79
;. F S X=$E(XX,I+LEN) Q:X=" "!(LEN'>0) S LEN=LEN-1
;. S LINE=$$SETL("",$E(XX,I,I+LEN),"",0,80)
;. S VALMCNT=VALMCNT+1
;. D SET^VALM10(VALMCNT,LINE,VALMCNT)
;. S I=I+LEN
Q
;
WRAP(TEXT,LENGTH) ;
;Break TEXT into substrings of length LENGTH
;Set each substring into array IBTMP with subscripts 1, 2, 3, etc.
;Adapted by Eric Dickerson and Nick Ward from Joel Russell's WRAP^GMTSORC and WRAP^TIUFLD
N IBI,IBY,IBFT1,IBFT2,LINENO
I $G(TEXT)']"" Q
S LINENO=1
F IBI=1:1 D Q:IBI=$L(TEXT," ")
. S IBTMP=$P(TEXT," ",IBI)
. I $L(IBTMP)>LENGTH D
. . S IBFT1=$E(IBTMP,1,LENGTH)
. . S IBFT2=$E(IBTMP,LENGTH+1,$L(IBTMP))
. . S $P(TEXT," ",IBI)=IBFT1_" "_IBFT2
S IBTMP(LINENO)=$P(TEXT," ")
F IBI=2:1 D Q:IBI'<$L(TEXT," ")
. S:$L($G(IBTMP(LINENO))_" "_$P(TEXT," ",IBI))>LENGTH LINENO=LINENO+1,IBY=1
. S IBTMP(LINENO)=$G(IBTMP(LINENO))_$S(+$G(IBY):"",1:" ")_$P(TEXT," ",IBI),IBY=0
Q
;
GETCMTS(CTIEN) ; -- Get Comment details
N CMTIEN,CNT
S CNT=0,CMTIEN="A"
F S CMTIEN=$O(^IBT(356,CTIEN,4,CMTIEN),-1) Q:'+CMTIEN D
. S CNT=CNT+1
. D GETONE(CTIEN,CMTIEN,CNT)
Q
;
GETONE(CTIEN,CMTIEN,CNT) ; -- Get one comment details
N COMMENT,DPT,DTENT,IENS,USR
Q:'$D(^IBT(356,CTIEN,4,CMTIEN))
S IENS=CMTIEN_","_CTIEN_","
S COMMENT=$$GET1^DIQ(356.04,IENS,1) ; Comment Text
S DTENT=$$GET1^DIQ(356.04,IENS,.01,"I") ; Internal Date/Time entered
S DTENT=$$FMTE^XLFDT(DTENT,"2DZ")
S USR=$$GET1^DIQ(356.04,IENS,.02) ; Entered by user
S DPT=$$GET1^DIQ(356.04,IENS,.03) ; Department of user who entered comment
S ^TMP($J,"IBTRECEX",CNT)=DTENT_U_USR_U_DPT_U_CMTIEN_U_COMMENT
Q
;
SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
; of the worklist - copied from IBCNCH2
; Input: LINE - Current line being created
; DATA - Information to be added to the end of the current line
; LABEL - Label to describe the information being added
; COL - Column position in line to add information add
; LNG - Maximum length of data information to include on the line
; Returns: Line updated with added information
S LINE=LINE_$J("",(COL-$L(LABEL)-$L(LINE)))_LABEL_$E(DATA,1,LNG)
Q LINE
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP($J,"IBTRECEX"),^TMP($J,"IBTREC")
D FULL^VALM1,CLEAN^VALM10
Q
;
EXPND ; -- expand code
Q
;
ADDCOM ; Add Comment Logic
N DIR,DA,IBFDA,IENS,X,Y
D FULL^VALM1
S VALMBCK="R"
S IENS="+1,"_CTIEN_","
S IBFDA(356.04,IENS,.01)=DT ; Date is today
S IBFDA(356.04,IENS,.02)=DUZ ; User is current user
;Get Department
S DIR(0)="356.04,.03" D ^DIR
Q:+$G(DIRUT) ; Quit if user escaped
S IBFDA(356.04,IENS,.03)=Y ; Department is Department
;Get Comment
S DIR(0)="356.04,1" D ^DIR
Q:+$G(DIRUT)!(Y']"") ; Quit if user escaped or comment is empty
S IBFDA(356.04,IENS,1)=Y ; Comment is Comment
D UPDATE^DIE(,"IBFDA")
;Now rebuild the list!
D INIT
Q
EDCOM ; Edit Comment Logic
N COMIEN,COMCNT,DIR,IBFDA
S VALMBCK="R"
D FULL^VALM1
S COMIEN=$$SELCOM(0,"Select a comment to edit",.COMCNT,"IBTRECEX")
Q:'COMIEN
S IENS=COMIEN_","_CTIEN_","
S IBFDA(356.04,IENS,.02)=DUZ ; User is current user
;Get Department
S DIR(0)="356.04,.03",DIR("B")=$$GET1^DIQ(356.04,IENS,.03) D ^DIR
Q:+$G(DIRUT) ; Quit if user escaped
S IBFDA(356.04,IENS,.03)=Y ; Department is Department
;Get Comment
S DIR(0)="356.04,1",DIR("B")=$$GET1^DIQ(356.04,IENS,1) D ^DIR
Q:+$G(DIRUT) ; Quit if user escaped or comment is empty
S IBFDA(356.04,IENS,1)=Y ; Comment is Comment
D FILE^DIE(,"IBFDA")
D INIT
Q
DELCOM ; Delete Comment Logic
N COMIEN,COMCNT,DIR,I,IBERR,IBFDA,IBTMP,X,Y,IBOKAY
S VALMBCK="R"
D FULL^VALM1
S COMIEN=$$SELCOM(0,"Select a comment to delete",.COMCNT,"IBTRECEX")
Q:'COMIEN
S IENS=COMIEN_","_CTIEN_","
W !!,*7,"You have selected this comment:",!
D WRAP($$GET1^DIQ(356.04,IENS,1),80)
S I=0 F S I=$O(IBTMP(I)) Q:'+I W !,IBTMP(I)
S DIR(0)="Y",DIR("A")="Are you sure you want to delete this comment",DIR("B")="NO" D ^DIR
K DIR
Q:Y'=1 ; Anything other than yes means no
I $G(IBROTH) S IBOKAY=0 D Q:'IBOKAY
. S I=0 F S I=$O(^IBT(356,CTIEN,4,I)) Q:'+I D Q:IBOKAY
. . I I'=COMIEN,$L($P($G(^IBT(356,CTIEN,4,I,1)),U))>14 S IBOKAY=1
. I 'IBOKAY D
. . W !,"The RNB of OTHER requires a Comment of at least 15 characters.",!,"No comment currently satisfies this requirement."
. . K DIR D PAUSE^VALM1
S IBFDA(356.04,IENS,.01)="@" D FILE^DIE(,"IBFDA","IBERR")
W !,"Comment has been deleted."
D PAUSE^VALM1
D INIT
Q
;
EXSCN ; Exit Screen
S VALMBCK="R"
W !!,*7,"I'm sorry, Dave, I'm afaid I cannot let you do that."
D PAUSE^VALM1
Q
;
SELCOM(FULL,PROMPT,COMCNT,WLIST) ; copied from IBCNCH
; Select Entry(s) to perform an action upon
; Input: FULL - 1 - full screen mode, 0 otherwise
; PROMPT - Prompt to be displayed to the user
; WLIST - Worklist, the user is selecting from
; ^TMP($J,"IBCNCHIX") - Index of displayed lines of the Comment
; History Worklist
; Output: COMCNT - Comment Number of the selected Comment
; Returns: Select Comment IEN
; Error message if invalid selection
N COMIEN,DIROUT,DIRUT,DLINE,DTOUT,DUOUT,END,START,X,Y
S:'$D(WLIST) WLIST="IBTRECEX"
S START=1,END=$O(^TMP($J,WLIST,""),-1)+0
D:FULL FULL^VALM1
S COMCNT=$P($P($G(XQORNOD(0)),"^",4),"=",2) ; User selection with action
S COMCNT=$TR(COMCNT,"/\; .",",,,,,") ; Check for multi-selection
;
I COMCNT["," D Q "" ; Invalid multi-selection
. W !,*7,">>>> Only single entry selection is allowed"
. K DIR
. D PAUSE^VALM1
;
I $O(^TMP($J,WLIST,""))="" D Q ""
. S X=$P(PROMPT," ",$L(PROMPT," "))
. W !,*7,">>>> No comments to "_X
. K DIR
. D PAUSE^VALM1
;
S:COMCNT="" COMCNT=$$SELENTRY(PROMPT,START,END)
Q:COMCNT="" ""
S COMIEN=$P($G(^TMP($J,WLIST,COMCNT)),"^",4)
I COMIEN="" D Q ""
. W !,*7,">>>> Invalid selection number"
. K DIR
. D PAUSE^VALM1
Q COMIEN
;
SELENTRY(PROMPT,START,END) ; select a comment
; copied fromm IBCNCH
; Input: PROMPT - Prompt to be displayed to the user
; START - Start comment # that can be selected
; END - Ending comment # that can be selected
; Returns: Selected Comment # or "" if not selected
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="NO^"_START_":"_END_":0"
S DIR("A")=PROMPT
D ^DIR K DIR
Q X
;
TRIGGER ; Trigger to create new comment when old Additional Comment field was edited
N IBFDA
S IENS="+1,"_DA_","
S IBFDA(356.04,IENS,.01)=DT ; Date is today
S IBFDA(356.04,IENS,.02)=DUZ ; User is current user
S IBFDA(356.04,IENS,1)=X ; Comment is Comment
D UPDATE^DIE(,"IBFDA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTREC 11264 printed Aug 26, 2025@22:43:55 Page 2
IBTREC ;BAH/MBS - Claims Tracking Comment Editor ; Nov 04, 2024@13:01
+1 ;;2.0;INTEGRATED BILLING;**796**;21-MAR-94;Build 34
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
EN(CTIEN,DFN) ; -- main entry point for IBT CLAIMS TRACKING CMT EDITOR
+1 ;K VALMQUIT
+2 NEW DIR,X,Y,IBROTH,IBRGENS,IBOKAY,IBREENT,IBRNB
+3 SET (IBROTH,IBRGENS,IBOKAY,IBREENT,IBUP)=0
+4 IF +$GET(CTIEN)'>0
Begin DoDot:1
+5 WRITE !!,*7,"Claims Tracking record is not identified."
+6 DO PAUSE^VALM1
End DoDot:1
QUIT
+7 IF +$GET(DFN)'>0
Begin DoDot:1
+8 SET DFN=$PIECE($GET(^IBT(356,CTIEN,0)),U,2)
End DoDot:1
+9 SET IBRNB=$$GET1^DIQ(356,CTIEN_",",.19,"I")
+10 IF $ORDER(^IBE(356.8,"B","GLOBAL SURGERY",0))=+$GET(IBRNB)
Begin DoDot:1
+11 NEW IBX,IENS,IBFDA,%DT,X,Y
+12 SET IBRGENS=1
+13 WRITE !!," For the RNB of GLOBAL SURGERY, enter the related Surgery Date"
+14 ;S %DT("A")=" Enter Surgery Date: ",%DT="AEX" D ^%DT S IBX=+Y,IBUP=$S(Y="^":1,1:0)
+15 SET DIR(0)="DAO^::EX"
SET DIR("A")=" Enter Surgery Date: "
+16 SET DIR("?")="A 2-digit year means no more than 20 years in the future, or 80 years in the past."
+17 SET DIR("?",1)="Examples of Valid Dates:"
+18 SET DIR("?",2)=" JAN 20 1957 or 20 JAN 57 or 1/20/57 or 012057 (omitting punctuation)"
+19 SET DIR("?",3)=" T (for TODAY), T+1 (for TOMORROW), T+2, T+7, etc."
+20 SET DIR("?",4)=" T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc."
+21 SET DIR("?",5)="If the year is omitted, the computer uses CURRENT YEAR."
+22 DO ^DIR
+23 SET IBX=+Y
SET IBUP=+$GET(DUOUT)
if IBUP
QUIT
+24 if IBX'?7N
QUIT
+25 SET IBX="Global Surgery: "_$$FMTE^XLFDT(IBX,2)
SET IBX=$EXTRACT(IBX,1,80)
+26 SET IENS="+1,"_CTIEN_","
+27 ; Date is today
SET IBFDA(356.04,IENS,.01)=DT
+28 ; User is current user
SET IBFDA(356.04,IENS,.02)=DUZ
+29 ; Comment is Comment
SET IBFDA(356.04,IENS,1)=IBX
+30 DO UPDATE^DIE(,"IBFDA")
End DoDot:1
if +$GET(IBUP)
QUIT
+31 IF $ORDER(^IBE(356.8,"B","OTHER",0))=+$GET(IBRNB)
Begin DoDot:1
+32 SET IBROTH=1
+33 WRITE !,"The RNB of OTHER requires a Comment of at least 15 characters"
End DoDot:1
+34 FOR
Begin DoDot:1
+35 SET IBOKAY=1
+36 IF 'IBREENT
SET DIR(0)="Y"
SET DIR("A")=" ADDITIONAL COMMENTS: "
SET DIR("B")="Y"
DO ^DIR
+37 IF $DATA(DUOUT)
SET IBUP=1
QUIT
+38 IF Y!(IBREENT)
SET IBREENT=1
SET IBFASTXT=0
DO EN^VALM("IBT CLAIMS TRACKING CMT EDITOR")
+39 IF IBROTH
Begin DoDot:2
+40 SET (I,IBOKAY)=0
FOR
SET I=$ORDER(^IBT(356,CTIEN,4,I))
if '+I
QUIT
Begin DoDot:3
+41 IF $LENGTH($PIECE($GET(^IBT(356,CTIEN,4,I,1)),U))>14
SET IBOKAY=1
End DoDot:3
if IBOKAY
QUIT
+42 IF 'IBOKAY
Begin DoDot:3
+43 WRITE !,"The RNB of OTHER requires a Comment of at least 15 characters.",!,"No comment currently satisfies this requirement."
+44 IF IBREENT
KILL DIR
DO PAUSE^VALM1
End DoDot:3
End DoDot:2
End DoDot:1
if IBOKAY!IBUP
QUIT
+45 if IBREENT
WRITE !!!
+46 QUIT
+47 ;
HDR ; -- header code
+1 DO PID^VADPT
NEW IBXR
+2 ;S VALMHDR(1)="Claims Tracking Entries for: "_$E($P($G(^DPT(DFN,0)),"^"),1,20)_" "_$E($G(^(0)),1)_VA("BID")
+3 SET XX=$EXTRACT($PIECE(^DPT(DFN,0),"^",1),1,20)_" "_$PIECE($$PT^IBEFUNC(DFN),"^",2)
+4 SET ZZ=$$GET1^DIQ(2,DFN_",",.03)
SET XX=XX_" "_ZZ
+5 SET VALMHDR(1)="RNB Comment History for: "_XX
+6 SET VALMHDR(2)="For "_$$GET1^DIQ(356,CTIEN_",",.18)_" on: "_$$GET1^DIQ(356,CTIEN_",",.06)
+7 QUIT
+8 ;
INIT ; -- init variables and list array
+1 KILL ^TMP($JOB,"IBTREC"),^TMP($JOB,"IBTRECEX")
+2 DO BLD
+3 QUIT
+4 ;
BLD ; -- Build list of comments
+1 NEW CNT,LINE,LN,XX
+2 DO GETCMTS(CTIEN)
+3 SET VALMCNT=0
SET LINE=""
SET CNT=""
+4 ;
+5 SET CNT=0
FOR
SET CNT=$ORDER(^TMP($JOB,"IBTRECEX",CNT))
if '+CNT
QUIT
Begin DoDot:1
+6 ; Set an empty line between records
IF CNT'=1
Begin DoDot:2
+7 SET VALMCNT=VALMCNT+1
+8 DO SET^VALM10(VALMCNT,"",VALMCNT)
End DoDot:2
+9 ;
+10 SET VALMCNT=VALMCNT+1
+11 DO BLDONEC(.VALMCNT,CNT)
End DoDot:1
+12 ;
+13 IF VALMCNT=0
Begin DoDot:1
+14 SET VALMCNT=1
SET XX=" *** No comments to display ***"
+15 DO SET^VALM10(VALMCNT,XX,VALMCNT)
End DoDot:1
+16 IF $GET(IBROTH)
SET VALMSG="RNB of OTHER requires Comment of at least 15 chars"
+17 QUIT
+18 ;
BLDONEC(VALMCNT,COMCNT) ; -- Build one item
+1 NEW DATALN,I,IBTMP,LINE
+2 ; Comment #
SET LINE=$$SETL("",COMCNT,"",1,4)
+3 SET DATALN=^TMP($JOB,"IBTRECEX",COMCNT)
+4 ; Dt Entered
SET XX=$PIECE(DATALN,"^",1)
+5 SET LINE=$$SETL(LINE,XX,"",6,12)
+6 DO SET^VALM10(VALMCNT,LINE,VALMCNT)
+7 ; Entered By
SET XX=$PIECE(DATALN,"^",2)
+8 SET LINE=$$SETL(LINE,XX,"",19,40)
+9 DO SET^VALM10(VALMCNT,LINE,VALMCNT)
+10 ; Department
SET XX=$PIECE(DATALN,"^",3)
+11 SET LINE=$$SETL(LINE,XX,"",62,17)
+12 DO SET^VALM10(VALMCNT,LINE,VALMCNT)
+13 ;S XX=$E($P(DATALN,"^",5),1,80) ; Start of Comment
+14 SET XX=$PIECE(DATALN,"^",5)
+15 DO WRAP(XX,80)
+16 SET I=0
FOR
SET I=$ORDER(IBTMP(I))
if '+I
QUIT
Begin DoDot:1
+17 SET VALMCNT=VALMCNT+1
+18 DO SET^VALM10(VALMCNT,IBTMP(I),VALMCNT)
End DoDot:1
+19 ;F I=1:80:$L(XX) D
+20 ;S I=1 F D Q:I'<$L(XX)
+21 ;. N X,LEN
+22 ;. S LEN=79
+23 ;. F S X=$E(XX,I+LEN) Q:X=" "!(LEN'>0) S LEN=LEN-1
+24 ;. S LINE=$$SETL("",$E(XX,I,I+LEN),"",0,80)
+25 ;. S VALMCNT=VALMCNT+1
+26 ;. D SET^VALM10(VALMCNT,LINE,VALMCNT)
+27 ;. S I=I+LEN
+28 QUIT
+29 ;
WRAP(TEXT,LENGTH) ;
+1 ;Break TEXT into substrings of length LENGTH
+2 ;Set each substring into array IBTMP with subscripts 1, 2, 3, etc.
+3 ;Adapted by Eric Dickerson and Nick Ward from Joel Russell's WRAP^GMTSORC and WRAP^TIUFLD
+4 NEW IBI,IBY,IBFT1,IBFT2,LINENO
+5 IF $GET(TEXT)']""
QUIT
+6 SET LINENO=1
+7 FOR IBI=1:1
Begin DoDot:1
+8 SET IBTMP=$PIECE(TEXT," ",IBI)
+9 IF $LENGTH(IBTMP)>LENGTH
Begin DoDot:2
+10 SET IBFT1=$EXTRACT(IBTMP,1,LENGTH)
+11 SET IBFT2=$EXTRACT(IBTMP,LENGTH+1,$LENGTH(IBTMP))
+12 SET $PIECE(TEXT," ",IBI)=IBFT1_" "_IBFT2
End DoDot:2
End DoDot:1
if IBI=$LENGTH(TEXT," ")
QUIT
+13 SET IBTMP(LINENO)=$PIECE(TEXT," ")
+14 FOR IBI=2:1
Begin DoDot:1
+15 if $LENGTH($GET(IBTMP(LINENO))_" "_$PIECE(TEXT," ",IBI))>LENGTH
SET LINENO=LINENO+1
SET IBY=1
+16 SET IBTMP(LINENO)=$GET(IBTMP(LINENO))_$SELECT(+$GET(IBY):"",1:" ")_$PIECE(TEXT," ",IBI)
SET IBY=0
End DoDot:1
if IBI'<$LENGTH(TEXT," ")
QUIT
+17 QUIT
+18 ;
GETCMTS(CTIEN) ; -- Get Comment details
+1 NEW CMTIEN,CNT
+2 SET CNT=0
SET CMTIEN="A"
+3 FOR
SET CMTIEN=$ORDER(^IBT(356,CTIEN,4,CMTIEN),-1)
if '+CMTIEN
QUIT
Begin DoDot:1
+4 SET CNT=CNT+1
+5 DO GETONE(CTIEN,CMTIEN,CNT)
End DoDot:1
+6 QUIT
+7 ;
GETONE(CTIEN,CMTIEN,CNT) ; -- Get one comment details
+1 NEW COMMENT,DPT,DTENT,IENS,USR
+2 if '$DATA(^IBT(356,CTIEN,4,CMTIEN))
QUIT
+3 SET IENS=CMTIEN_","_CTIEN_","
+4 ; Comment Text
SET COMMENT=$$GET1^DIQ(356.04,IENS,1)
+5 ; Internal Date/Time entered
SET DTENT=$$GET1^DIQ(356.04,IENS,.01,"I")
+6 SET DTENT=$$FMTE^XLFDT(DTENT,"2DZ")
+7 ; Entered by user
SET USR=$$GET1^DIQ(356.04,IENS,.02)
+8 ; Department of user who entered comment
SET DPT=$$GET1^DIQ(356.04,IENS,.03)
+9 SET ^TMP($JOB,"IBTRECEX",CNT)=DTENT_U_USR_U_DPT_U_CMTIEN_U_COMMENT
+10 QUIT
+11 ;
SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
+1 ; of the worklist - copied from IBCNCH2
+2 ; Input: LINE - Current line being created
+3 ; DATA - Information to be added to the end of the current line
+4 ; LABEL - Label to describe the information being added
+5 ; COL - Column position in line to add information add
+6 ; LNG - Maximum length of data information to include on the line
+7 ; Returns: Line updated with added information
+8 SET LINE=LINE_$JUSTIFY("",(COL-$LENGTH(LABEL)-$LENGTH(LINE)))_LABEL_$EXTRACT(DATA,1,LNG)
+9 QUIT LINE
+10 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP($JOB,"IBTRECEX"),^TMP($JOB,"IBTREC")
+2 DO FULL^VALM1
DO CLEAN^VALM10
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
ADDCOM ; Add Comment Logic
+1 NEW DIR,DA,IBFDA,IENS,X,Y
+2 DO FULL^VALM1
+3 SET VALMBCK="R"
+4 SET IENS="+1,"_CTIEN_","
+5 ; Date is today
SET IBFDA(356.04,IENS,.01)=DT
+6 ; User is current user
SET IBFDA(356.04,IENS,.02)=DUZ
+7 ;Get Department
+8 SET DIR(0)="356.04,.03"
DO ^DIR
+9 ; Quit if user escaped
if +$GET(DIRUT)
QUIT
+10 ; Department is Department
SET IBFDA(356.04,IENS,.03)=Y
+11 ;Get Comment
+12 SET DIR(0)="356.04,1"
DO ^DIR
+13 ; Quit if user escaped or comment is empty
if +$GET(DIRUT)!(Y']"")
QUIT
+14 ; Comment is Comment
SET IBFDA(356.04,IENS,1)=Y
+15 DO UPDATE^DIE(,"IBFDA")
+16 ;Now rebuild the list!
+17 DO INIT
+18 QUIT
EDCOM ; Edit Comment Logic
+1 NEW COMIEN,COMCNT,DIR,IBFDA
+2 SET VALMBCK="R"
+3 DO FULL^VALM1
+4 SET COMIEN=$$SELCOM(0,"Select a comment to edit",.COMCNT,"IBTRECEX")
+5 if 'COMIEN
QUIT
+6 SET IENS=COMIEN_","_CTIEN_","
+7 ; User is current user
SET IBFDA(356.04,IENS,.02)=DUZ
+8 ;Get Department
+9 SET DIR(0)="356.04,.03"
SET DIR("B")=$$GET1^DIQ(356.04,IENS,.03)
DO ^DIR
+10 ; Quit if user escaped
if +$GET(DIRUT)
QUIT
+11 ; Department is Department
SET IBFDA(356.04,IENS,.03)=Y
+12 ;Get Comment
+13 SET DIR(0)="356.04,1"
SET DIR("B")=$$GET1^DIQ(356.04,IENS,1)
DO ^DIR
+14 ; Quit if user escaped or comment is empty
if +$GET(DIRUT)
QUIT
+15 ; Comment is Comment
SET IBFDA(356.04,IENS,1)=Y
+16 DO FILE^DIE(,"IBFDA")
+17 DO INIT
+18 QUIT
DELCOM ; Delete Comment Logic
+1 NEW COMIEN,COMCNT,DIR,I,IBERR,IBFDA,IBTMP,X,Y,IBOKAY
+2 SET VALMBCK="R"
+3 DO FULL^VALM1
+4 SET COMIEN=$$SELCOM(0,"Select a comment to delete",.COMCNT,"IBTRECEX")
+5 if 'COMIEN
QUIT
+6 SET IENS=COMIEN_","_CTIEN_","
+7 WRITE !!,*7,"You have selected this comment:",!
+8 DO WRAP($$GET1^DIQ(356.04,IENS,1),80)
+9 SET I=0
FOR
SET I=$ORDER(IBTMP(I))
if '+I
QUIT
WRITE !,IBTMP(I)
+10 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this comment"
SET DIR("B")="NO"
DO ^DIR
+11 KILL DIR
+12 ; Anything other than yes means no
if Y'=1
QUIT
+13 IF $GET(IBROTH)
SET IBOKAY=0
Begin DoDot:1
+14 SET I=0
FOR
SET I=$ORDER(^IBT(356,CTIEN,4,I))
if '+I
QUIT
Begin DoDot:2
+15 IF I'=COMIEN
IF $LENGTH($PIECE($GET(^IBT(356,CTIEN,4,I,1)),U))>14
SET IBOKAY=1
End DoDot:2
if IBOKAY
QUIT
+16 IF 'IBOKAY
Begin DoDot:2
+17 WRITE !,"The RNB of OTHER requires a Comment of at least 15 characters.",!,"No comment currently satisfies this requirement."
+18 KILL DIR
DO PAUSE^VALM1
End DoDot:2
End DoDot:1
if 'IBOKAY
QUIT
+19 SET IBFDA(356.04,IENS,.01)="@"
DO FILE^DIE(,"IBFDA","IBERR")
+20 WRITE !,"Comment has been deleted."
+21 DO PAUSE^VALM1
+22 DO INIT
+23 QUIT
+24 ;
EXSCN ; Exit Screen
+1 SET VALMBCK="R"
+2 WRITE !!,*7,"I'm sorry, Dave, I'm afaid I cannot let you do that."
+3 DO PAUSE^VALM1
+4 QUIT
+5 ;
SELCOM(FULL,PROMPT,COMCNT,WLIST) ; copied from IBCNCH
+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 ; WLIST - Worklist, the user is selecting from
+5 ; ^TMP($J,"IBCNCHIX") - Index of displayed lines of the Comment
+6 ; History Worklist
+7 ; Output: COMCNT - Comment Number of the selected Comment
+8 ; Returns: Select Comment IEN
+9 ; Error message if invalid selection
+10 NEW COMIEN,DIROUT,DIRUT,DLINE,DTOUT,DUOUT,END,START,X,Y
+11 if '$DATA(WLIST)
SET WLIST="IBTRECEX"
+12 SET START=1
SET END=$ORDER(^TMP($JOB,WLIST,""),-1)+0
+13 if FULL
DO FULL^VALM1
+14 ; User selection with action
SET COMCNT=$PIECE($PIECE($GET(XQORNOD(0)),"^",4),"=",2)
+15 ; Check for multi-selection
SET COMCNT=$TRANSLATE(COMCNT,"/\; .",",,,,,")
+16 ;
+17 ; Invalid multi-selection
IF COMCNT[","
Begin DoDot:1
+18 WRITE !,*7,">>>> Only single entry selection is allowed"
+19 KILL DIR
+20 DO PAUSE^VALM1
End DoDot:1
QUIT ""
+21 ;
+22 IF $ORDER(^TMP($JOB,WLIST,""))=""
Begin DoDot:1
+23 SET X=$PIECE(PROMPT," ",$LENGTH(PROMPT," "))
+24 WRITE !,*7,">>>> No comments to "_X
+25 KILL DIR
+26 DO PAUSE^VALM1
End DoDot:1
QUIT ""
+27 ;
+28 if COMCNT=""
SET COMCNT=$$SELENTRY(PROMPT,START,END)
+29 if COMCNT=""
QUIT ""
+30 SET COMIEN=$PIECE($GET(^TMP($JOB,WLIST,COMCNT)),"^",4)
+31 IF COMIEN=""
Begin DoDot:1
+32 WRITE !,*7,">>>> Invalid selection number"
+33 KILL DIR
+34 DO PAUSE^VALM1
End DoDot:1
QUIT ""
+35 QUIT COMIEN
+36 ;
SELENTRY(PROMPT,START,END) ; select a comment
+1 ; copied fromm IBCNCH
+2 ; Input: PROMPT - Prompt to be displayed to the user
+3 ; START - Start comment # that can be selected
+4 ; END - Ending comment # that can be selected
+5 ; Returns: Selected Comment # or "" if not selected
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+7 SET DIR(0)="NO^"_START_":"_END_":0"
+8 SET DIR("A")=PROMPT
+9 DO ^DIR
KILL DIR
+10 QUIT X
+11 ;
TRIGGER ; Trigger to create new comment when old Additional Comment field was edited
+1 NEW IBFDA
+2 SET IENS="+1,"_DA_","
+3 ; Date is today
SET IBFDA(356.04,IENS,.01)=DT
+4 ; User is current user
SET IBFDA(356.04,IENS,.02)=DUZ
+5 ; Comment is Comment
SET IBFDA(356.04,IENS,1)=X
+6 DO UPDATE^DIE(,"IBFDA")
+7 QUIT
