TIURL ; SLC/JER - List Management Library ;2/21/01
;;1.0;TEXT INTEGRATION UTILITIES;**88,100,224**;Jun 20, 1997;Build 7
; 11/14/00 Moved UPDATEID, etc to TIURL1
;
UPRBLD(TIUCHNG,ITEMS) ; Refreshes, updates, or rebuilds the list
;after various actions. Also restores video.
; Receives optional arrays TIUCHNG, ITEMS by ref.
; Checks TIUCHNG("RBLD"),TIUCHNG("UPDATE"), & TIUCHNG("REFRESH");
;does nothing if none of these is defined.
; Items in ITEMS list are updated (depending on TIUCHNG), and
;their video attributes are restored.
N TIUI,TIUREC,TIUJ,RTN
S RTN=$G(^TMP("TIUR",$J,"RTN"))
; -- Restore video attributes for selected items:
; (Rebuild code, except for TIUROR, does its own video restore)
I '$G(TIUCHNG("RBLD"))!(RTN="TIUROR") D
. S TIUJ=0
. F S TIUJ=$O(ITEMS(TIUJ)) Q:'TIUJ D
. . Q:TIUJ=$P($G(TIUGLINK),U,2) ; Don't restore midattach ID child
. . D RESTORE^VALM10(TIUJ)
; -- If TIUROR screen needs changes, it is always
; rebuilt, not updated:
I RTN="TIUROR",$G(TIUCHNG("UPDATE")) S TIUCHNG("RBLD")=1
;VMP/ELR ADDED THE FOLLOWING 2 LINES IN PATCH 224
I RTN="TIUR",$G(TIUCHNG("UPDATE")) S TIUCHNG("RBLD")=1
I RTN="TIURM",$G(TIUCHNG("UPDATE")) S TIUCHNG("RBLD")=1
; -- Rebuild, Update, or Refresh list:
; (In cases (e.g.browse) where more than one action
; was performed, TIUCHNG("RBLD") may coexist w TIUCHNG("UPDATE"),
; etc., so order is important.)
I $G(TIUCHNG("RBLD")) D Q
. W !,"Rebuilding the list..."
. I RTN="TIUROR" D RBLD^TIUROR Q
. ; -- If not in 2b, pause for feedback ("Rebuilding",
. ; "Entry deleted", etc):
. H 2
. I RTN="TIURM" D RBLD^TIURM Q
. I RTN="TIURPTTL" D RBLD^TIURPTTL Q
. I RTN="TIURTITL" D RBLD^TIURTITL Q
. I RTN="TIUR" D RBLD^TIUR
I $G(TIUCHNG("UPDATE")),$D(ITEMS) D Q
. S TIUI=""
. W !,"Updating the list..."
. F S TIUI=$O(ITEMS(TIUI)) Q:'TIUI D
. . D SETREC(TIUI,.TIUREC)
. . ;VMP/ELR ADDED THE FOLLOWING LINE IN PATCH 224
. . I $G(TIUREC)="" Q
. . S ^TMP("TIUR",$J,TIUI,0)=TIUREC
I $G(TIUCHNG("REFRESH")) D Q
. W !,"Refreshing the list..."
Q
;
SETREC(LINENO,TIUREC,PFIXFLAG) ; Update line LINENO with [new prefix], new flds
; Combined fields so that SETREC works for MIS as well as
;CLINICIAN LM templates
; PFIXFLAG=1: update prefix (as well as other flds).
; New prefix is for unexpanded state of line.
N DIC,DIQ,DA,DR,TIUR,ADT,DDT,LCT,AUT,AMD,EDT,SDT,TIULST4
N MOM,DOC,MISEDT,ITEMNODE
S ITEMNODE=^TMP("TIURIDX",$J,LINENO)
S DA=+$P(ITEMNODE,U,2)
S DIQ="TIUR",DIC=8925,DIQ(0)="IE"
S DR=".01;.02;.05;.07;.08;.1;1202;1204;1208;1209;1301;1307;1501;1507"
D EN^DIQ1 Q:$D(TIUR)'>9
S DOC=$$PNAME^TIULC1(+TIUR(8925,DA,.01,"I"))
I DOC="Addendum" D
. S MOM=+$P(^TIU(8925,DA,0),U,6)
. S DOC=DOC_" to "_$$PNAME^TIULC1(+$G(^TIU(8925,MOM,0)))
S TIULST4=$E($P($G(^DPT(TIUR(8925,DA,.02,"I"),0)),U,9),6,9)
S TIULST4="("_$E(TIUR(8925,DA,.02,"E"))_TIULST4_")"
S ADT=$$DATE^TIULS(TIUR(8925,DA,.07,"I"),"MM/DD/YY")
S DDT=$$DATE^TIULS(TIUR(8925,DA,.08,"I"),"MM/DD/YY")
S AMD=$$NAME^TIULS(TIUR(8925,DA,1208,"E"),"LAST, FI MI")
S AUT=$$NAME^TIULS(TIUR(8925,DA,1202,"E"),"LAST, FI MI")
S EDT=$$DATE^TIULS(TIUR(8925,DA,1301,"I"),"MM/DD/YY")
S MISEDT=$$DATE^TIULS(TIUR(8925,DA,1307,"I"),"MM/DD/YY")
S SDT=$S(+TIUR(8925,DA,1507,"I"):TIUR(8925,DA,1507,"I"),TIUR(8925,DA,.05,"I")'<7:+TIUR(8925,DA,1501,"I"),1:"")
S SDT=$$DATE^TIULS(SDT,"MM/DD/YY")
S LCT=$G(TIUR(8925,DA,.1,"E"))
; -- Set prefix_patient/title into ^TMP("TIUR",$J,LINENO,0),
; then into TIUREC: --
I $G(PFIXFLAG) D SETPT^TIURL1(LINENO)
S TIUREC=^TMP("TIUR",$J,LINENO,0)
; -- Set other fields into TIUREC: --
S TIUREC=$$SETFLD^VALM1(LINENO,TIUREC,"NUMBER")
S TIUREC=$$SETFLD^VALM1($$LOWER^TIULS(TIUR(8925,DA,.05,"E")),TIUREC,"STATUS")
S TIUREC=$$SETFLD^VALM1(TIULST4,TIUREC,"LAST I/LAST 4")
S TIUREC=$$SETFLD^VALM1(DOC,TIUREC,"DOCUMENT TYPE")
S:$D(VALMDDF("ADMISSION DATE")) TIUREC=$$SETFLD^VALM1(ADT,TIUREC,"ADMISSION DATE")
S:$D(VALMDDF("DISCH DATE")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"DISCH DATE")
S:$D(VALMDDF("DICT DATE")) TIUREC=$$SETFLD^VALM1(MISEDT,TIUREC,"DICT DATE")
S:$D(VALMDDF("LINE COUNT")) TIUREC=$$SETFLD^VALM1(LCT,TIUREC,"LINE COUNT")
S:$D(VALMDDF("REF DATE")) TIUREC=$$SETFLD^VALM1(EDT,TIUREC,"REF DATE")
S:$D(VALMDDF("SIG DATE")) TIUREC=$$SETFLD^VALM1(SDT,TIUREC,"SIG DATE")
S TIUREC=$$SETFLD^VALM1(AUT,TIUREC,"AUTHOR")
S:$D(VALMDDF("COSIGNER")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"COSIGNER")
S:$D(VALMDDF("ATTENDING")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"ATTENDING")
S ^TMP("TIUR",$J,LINENO,0)=TIUREC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIURL 4624 printed Apr 09, 2024@21:46:11 Page 2
TIURL ; SLC/JER - List Management Library ;2/21/01
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**88,100,224**;Jun 20, 1997;Build 7
+2 ; 11/14/00 Moved UPDATEID, etc to TIURL1
+3 ;
UPRBLD(TIUCHNG,ITEMS) ; Refreshes, updates, or rebuilds the list
+1 ;after various actions. Also restores video.
+2 ; Receives optional arrays TIUCHNG, ITEMS by ref.
+3 ; Checks TIUCHNG("RBLD"),TIUCHNG("UPDATE"), & TIUCHNG("REFRESH");
+4 ;does nothing if none of these is defined.
+5 ; Items in ITEMS list are updated (depending on TIUCHNG), and
+6 ;their video attributes are restored.
+7 NEW TIUI,TIUREC,TIUJ,RTN
+8 SET RTN=$GET(^TMP("TIUR",$JOB,"RTN"))
+9 ; -- Restore video attributes for selected items:
+10 ; (Rebuild code, except for TIUROR, does its own video restore)
+11 IF '$GET(TIUCHNG("RBLD"))!(RTN="TIUROR")
Begin DoDot:1
+12 SET TIUJ=0
+13 FOR
SET TIUJ=$ORDER(ITEMS(TIUJ))
if 'TIUJ
QUIT
Begin DoDot:2
+14 ; Don't restore midattach ID child
if TIUJ=$PIECE($GET(TIUGLINK),U,2)
QUIT
+15 DO RESTORE^VALM10(TIUJ)
End DoDot:2
End DoDot:1
+16 ; -- If TIUROR screen needs changes, it is always
+17 ; rebuilt, not updated:
+18 IF RTN="TIUROR"
IF $GET(TIUCHNG("UPDATE"))
SET TIUCHNG("RBLD")=1
+19 ;VMP/ELR ADDED THE FOLLOWING 2 LINES IN PATCH 224
+20 IF RTN="TIUR"
IF $GET(TIUCHNG("UPDATE"))
SET TIUCHNG("RBLD")=1
+21 IF RTN="TIURM"
IF $GET(TIUCHNG("UPDATE"))
SET TIUCHNG("RBLD")=1
+22 ; -- Rebuild, Update, or Refresh list:
+23 ; (In cases (e.g.browse) where more than one action
+24 ; was performed, TIUCHNG("RBLD") may coexist w TIUCHNG("UPDATE"),
+25 ; etc., so order is important.)
+26 IF $GET(TIUCHNG("RBLD"))
Begin DoDot:1
+27 WRITE !,"Rebuilding the list..."
+28 IF RTN="TIUROR"
DO RBLD^TIUROR
QUIT
+29 ; -- If not in 2b, pause for feedback ("Rebuilding",
+30 ; "Entry deleted", etc):
+31 HANG 2
+32 IF RTN="TIURM"
DO RBLD^TIURM
QUIT
+33 IF RTN="TIURPTTL"
DO RBLD^TIURPTTL
QUIT
+34 IF RTN="TIURTITL"
DO RBLD^TIURTITL
QUIT
+35 IF RTN="TIUR"
DO RBLD^TIUR
End DoDot:1
QUIT
+36 IF $GET(TIUCHNG("UPDATE"))
IF $DATA(ITEMS)
Begin DoDot:1
+37 SET TIUI=""
+38 WRITE !,"Updating the list..."
+39 FOR
SET TIUI=$ORDER(ITEMS(TIUI))
if 'TIUI
QUIT
Begin DoDot:2
+40 DO SETREC(TIUI,.TIUREC)
+41 ;VMP/ELR ADDED THE FOLLOWING LINE IN PATCH 224
+42 IF $GET(TIUREC)=""
QUIT
+43 SET ^TMP("TIUR",$JOB,TIUI,0)=TIUREC
End DoDot:2
End DoDot:1
QUIT
+44 IF $GET(TIUCHNG("REFRESH"))
Begin DoDot:1
+45 WRITE !,"Refreshing the list..."
End DoDot:1
QUIT
+46 QUIT
+47 ;
SETREC(LINENO,TIUREC,PFIXFLAG) ; Update line LINENO with [new prefix], new flds
+1 ; Combined fields so that SETREC works for MIS as well as
+2 ;CLINICIAN LM templates
+3 ; PFIXFLAG=1: update prefix (as well as other flds).
+4 ; New prefix is for unexpanded state of line.
+5 NEW DIC,DIQ,DA,DR,TIUR,ADT,DDT,LCT,AUT,AMD,EDT,SDT,TIULST4
+6 NEW MOM,DOC,MISEDT,ITEMNODE
+7 SET ITEMNODE=^TMP("TIURIDX",$JOB,LINENO)
+8 SET DA=+$PIECE(ITEMNODE,U,2)
+9 SET DIQ="TIUR"
SET DIC=8925
SET DIQ(0)="IE"
+10 SET DR=".01;.02;.05;.07;.08;.1;1202;1204;1208;1209;1301;1307;1501;1507"
+11 DO EN^DIQ1
if $DATA(TIUR)'>9
QUIT
+12 SET DOC=$$PNAME^TIULC1(+TIUR(8925,DA,.01,"I"))
+13 IF DOC="Addendum"
Begin DoDot:1
+14 SET MOM=+$PIECE(^TIU(8925,DA,0),U,6)
+15 SET DOC=DOC_" to "_$$PNAME^TIULC1(+$GET(^TIU(8925,MOM,0)))
End DoDot:1
+16 SET TIULST4=$EXTRACT($PIECE($GET(^DPT(TIUR(8925,DA,.02,"I"),0)),U,9),6,9)
+17 SET TIULST4="("_$EXTRACT(TIUR(8925,DA,.02,"E"))_TIULST4_")"
+18 SET ADT=$$DATE^TIULS(TIUR(8925,DA,.07,"I"),"MM/DD/YY")
+19 SET DDT=$$DATE^TIULS(TIUR(8925,DA,.08,"I"),"MM/DD/YY")
+20 SET AMD=$$NAME^TIULS(TIUR(8925,DA,1208,"E"),"LAST, FI MI")
+21 SET AUT=$$NAME^TIULS(TIUR(8925,DA,1202,"E"),"LAST, FI MI")
+22 SET EDT=$$DATE^TIULS(TIUR(8925,DA,1301,"I"),"MM/DD/YY")
+23 SET MISEDT=$$DATE^TIULS(TIUR(8925,DA,1307,"I"),"MM/DD/YY")
+24 SET SDT=$SELECT(+TIUR(8925,DA,1507,"I"):TIUR(8925,DA,1507,"I"),TIUR(8925,DA,.05,"I")'<7:+TIUR(8925,DA,1501,"I"),1:"")
+25 SET SDT=$$DATE^TIULS(SDT,"MM/DD/YY")
+26 SET LCT=$GET(TIUR(8925,DA,.1,"E"))
+27 ; -- Set prefix_patient/title into ^TMP("TIUR",$J,LINENO,0),
+28 ; then into TIUREC: --
+29 IF $GET(PFIXFLAG)
DO SETPT^TIURL1(LINENO)
+30 SET TIUREC=^TMP("TIUR",$JOB,LINENO,0)
+31 ; -- Set other fields into TIUREC: --
+32 SET TIUREC=$$SETFLD^VALM1(LINENO,TIUREC,"NUMBER")
+33 SET TIUREC=$$SETFLD^VALM1($$LOWER^TIULS(TIUR(8925,DA,.05,"E")),TIUREC,"STATUS")
+34 SET TIUREC=$$SETFLD^VALM1(TIULST4,TIUREC,"LAST I/LAST 4")
+35 SET TIUREC=$$SETFLD^VALM1(DOC,TIUREC,"DOCUMENT TYPE")
+36 if $DATA(VALMDDF("ADMISSION DATE"))
SET TIUREC=$$SETFLD^VALM1(ADT,TIUREC,"ADMISSION DATE")
+37 if $DATA(VALMDDF("DISCH DATE"))
SET TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"DISCH DATE")
+38 if $DATA(VALMDDF("DICT DATE"))
SET TIUREC=$$SETFLD^VALM1(MISEDT,TIUREC,"DICT DATE")
+39 if $DATA(VALMDDF("LINE COUNT"))
SET TIUREC=$$SETFLD^VALM1(LCT,TIUREC,"LINE COUNT")
+40 if $DATA(VALMDDF("REF DATE"))
SET TIUREC=$$SETFLD^VALM1(EDT,TIUREC,"REF DATE")
+41 if $DATA(VALMDDF("SIG DATE"))
SET TIUREC=$$SETFLD^VALM1(SDT,TIUREC,"SIG DATE")
+42 SET TIUREC=$$SETFLD^VALM1(AUT,TIUREC,"AUTHOR")
+43 if $DATA(VALMDDF("COSIGNER"))
SET TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"COSIGNER")
+44 if $DATA(VALMDDF("ATTENDING"))
SET TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"ATTENDING")
+45 SET ^TMP("TIUR",$JOB,LINENO,0)=TIUREC
+46 QUIT
