- 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 Jan 18, 2025@03:46:29 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