TIUPEVN1 ; SLC/JER - Event logger Cont'd ;05/20/10 14:09
;;1.0;TEXT INTEGRATION UTILITIES;**81,250**;Jun 20, 1997;Build 14
;
; ICR #10006 - ^DIC Routine & DIC, DLAYGO, X, & Y local vars
; #10018 - ^DIE Routine & DIE, DA, DR, DTOUT, & DUOUT local vars
; #10004 - EN^DIQ Routine & DIC, DA, X, & Y local vars
; #10015 - EN^DIQ1 Routine & DIC, DIQ, DA, & DR local vars
; #10081 - SETUP^XQALERT Routine & XQADATA, XQAID, XQAMSG, & XQAROU local vars
;
FIELDS(EVNTDA,MSG) ; ---- Log missing/incorrect field errors for
; specific fields in UPLOAD LOG file (#8925.4),
; in multiple fl. TIU*1*81 moved from TIUPEVNT
N TIUI S TIUI=0
F S TIUI=$O(MSG("DIERR",TIUI)) Q:+TIUI'>0 D
. N DA,DR,DIC,DIE,DLAYGO,X,Y S DIC="^TIU(8925.4,"_EVNTDA_",1,",DIC(0)="L"
. I '$D(MSG("DIERR",TIUI,"PARAM","FILE")) Q
. S ^TIU(8925.4,EVNTDA,1,0)="^8925.42^^",DA(1)=EVNTDA
. S DLAYGO=8925.42,X=""""_MSG("DIERR",TIUI,"PARAM","FILE")_""""
. D ^DIC Q:+Y'>0
. S DIE=DIC,DA(1)=EVNTDA,DA=+Y
. S DR=".02///"_+$G(MSG("DIERR",TIUI,"PARAM","IENS"))_";.03///"_$G(MSG("DIERR",TIUI,"PARAM","FIELD"))_";.04///"_$G(MSG("DIERR",TIUI,"PARAM",3))
. D ^DIE,FLDALRT(EVNTDA,DA,$P($G(^TIU(8925.4,+EVNTDA,0)),U,4))
Q
FLDALRT(EVNTDA,EVNTDA1,ERRMSG) ; ---- Send alerts for missing field errors
; TIU*1*81 moved from TIUPEVNT
N XQA,XQAID,XQADATA,XQAMSG,XQAKILL,XQAROU,TIUI,TIUSUB,TYPE,EVNTDA10
N NOTEDA,NOTE0
; ---- TIU*1*81 If this is a TIU docmt, get its title for TYPE
S EVNTDA10=$G(^TIU(8925.4,EVNTDA,1,EVNTDA1,0))
I $P(EVNTDA10,U)=8925 D
. S NOTEDA=$P(EVNTDA10,U,2),NOTE0=$G(^TIU(8925,NOTEDA,0)),TYPE=+NOTE0
. ; ---- TIU*1*81 If note is addendum, get type of parent note instead
. I +$$ISADDNDM^TIULC1(NOTEDA) S TYPE=+$$DADTYPE^TIUPUTC(NOTEDA)
; ---- else get TYPE from $HDR line, e.g. Progress Notes (3)
I $G(TYPE)'>0 S TYPE=+$G(TIUREC("TYPE"))
I TYPE D WHOGETS^TIUPEVN1(.XQA,TYPE)
; ---- If no docmt def param recipients found, try site recipients
I $D(XQA)'>9 D
. S TIUI=$O(^TIU(8925.99,"B",+$G(DUZ(2)),0)) S:+TIUI'>0 TIUI=+$O(^TIU(8925.99,0))
. S TIUSUB=0 F S TIUSUB=$O(^TIU(8925.99,+TIUI,2,TIUSUB)) Q:TIUSUB'>0 D
. . S XQA($G(^TIU(8925.99,+TIUI,2,TIUSUB,0)))=""
Q:$D(XQA)'>9
S XQAID="TIUERR"_","_EVNTDA_","_EVNTDA1
S XQAMSG=ERRMSG
W:'$D(ZTQUEUED) !!,XQAMSG
S XQADATA=ERRMSG_";"_EVNTDA_";"_EVNTDA1
S XQAROU="FLDISP^TIUPEVN1" ; TIU*1*81 moved from TIUPEVNT
D SETUP^XQALERT
Q
FLDISP ; ---- Alert follow-up action for missing field errors
; TIU*1*81 moved from TIUPEVNT
N DIE,DA,DR,EVNTDA,EVNTDA1,EVNTREC,TIUFIX,TIULINK S TIUFIX=0
S EVNTDA=+$P(XQADATA,";",2),EVNTDA1=+$P(XQADATA,";",3)
S EVNTREC=$G(^TIU(8925.4,EVNTDA,1,EVNTDA1,0)) Q:+EVNTREC'>0
S DIE=$P(EVNTREC,U),DA=$P(EVNTREC,U,2)
S DR=$P(EVNTREC,U,3)_"//"_$P(EVNTREC,U,4)
S TIUFIX=$$FIXED(DIE,+DA,+DR)
I +TIUFIX>0 D Q
. W:TIUFIX=1 !!,"Missing field already filled in by another method..."
. W:TIUFIX=2 !!,"Record #",DA," has been deleted by an authorized user..."
. W !," Nothing left to resolve." H 3
. S XQAKILL=0 D FLDRSLV(EVNTDA)
W !!,"You may now enter the correct information:",!
W !,$P(XQADATA,";"),!
D RECDISP(DIE,DA)
I DIE=8925,(+DR=1405) D
. N TIUREASX,TIUDA
. S TIUDA=+DA
. S TIUREASX=$$REASSIGN^TIULC1(+$G(^TIU(8925,+TIUDA,0)))
. I TIUREASX]"" X TIUREASX S TIULINK=1
I '+$G(TIULINK) D ^DIE
; ---- If TIU Document, do post-filing action send signature alerts
I DIE="^TIU(8925," D
. N TIUREC,TIUPOST,DR,DIE,TYPE,TIUD12,TIUD13,TIUEBY,TIUAU,TIUEC
. S TYPE=$S(+$$ISADDNDM^TIULC1(DA):+$G(^TIU(8925,+$P(^TIU(8925,DA,0),U,6),0)),1:+$G(^TIU(8925,DA,0)))
. S TIUPOST=$$POSTFILE^TIULC1(TYPE)
. S TIUREC("#")=DA
. I TIUPOST]"" X TIUPOST I 1
. ;if not entered by the author or expected cosigner record VBC Line Count
. S TIUD12=$G(^TIU(8925,DA,12)),TIUD13=$G(^(13))
. S TIUEBY=$P(TIUD13,U,2),TIUAU=$P(TIUD12,U,2),TIUEC=$P(TIUD13,U,8)
. I ((+TIUEBY>0)&(+TIUAU>0))&((TIUEBY'=TIUAU)&(TIUEBY'=TIUEC)) D LINES^TIUSRVPT(DA)
. D SEND^TIUALRT(DA)
S TIUFIX=$$FIXED(DIE,+DA,+DR)
I +$G(TIUFIX)'>0 K XQAKILL Q
S XQAKILL=0
; ---- If field is fixed, evaluate whether whole event is resolved
D FLDRSLV(EVNTDA)
Q
RECDISP(DIC,DA) ; ---- Call DIQ to display the existing record
; TIU*1*81 moved from TIUPEVNT
N X,Y,DIQ,DR
I '+$$READ^TIUU("Y","Display ENTIRE existing record","NO") Q
W ! S DIC=$G(^DIC(DIC,0,"GL"))
D EN^DIQ
Q
FIXED(DIC,DA,DR) ; ---- Evaluate whether the field has been filled in
; TIU*1*81 moved from TIUPEVNT
N DIQ,X,Y,TIUY,TIUFIX S TIUY=0,DIQ="TIUFIX",DIQ(0)="IN"
I '$D(^TIU(8925,DA,0)) S TIUY=2 G FIXX
D EN^DIQ1 I $D(TIUFIX) S TIUY=1
FIXX Q TIUY
FLDRSLV(ERRDA) ; ---- Evaluate missing field errors; mark resolved
; TIU*1*81 moved from TIUPEVNT
N TIUK,TIUFLD,RSLVED
S TIUK=0,RSLVED=1
; ---- TIU*1*81 Mark resolved only if ALL missing fields are fixed
F S TIUK=$O(^TIU(8925.4,+ERRDA,1,TIUK)) Q:+TIUK'>0 Q:'RSLVED D
. N DIC,DIQ,DA,DR S DA=TIUK,DIC="^TIU(8925.4,"_+ERRDA_",1,"
. S DR=".01:.04",DIQ="TIUFLD(" D EN^DIQ1 Q:$D(TIUFLD)'>9
. I '$$FIXED(8925,+$G(TIUFLD(8925.42,DA,.02)),+$G(TIUFLD(8925.42,DA,.03)))=1 S RSLVED=0
Q:'RSLVED
N DIE,DR
S DA=+ERRDA,DIE=8925.4,DR=".06////1;.07////"_$$NOW^TIULC D ^DIE
Q
;
WHOGETS(TIUY,TIUTYP) ; ---- Who gets filing error/missing field alerts;
; Get 8925.95 (document parameter) recipients.
; ---- TIUTYP is title IFN in 8925.1 if valid title was uploaded, else
; is IFN of entry from $HDR line: e.g. PROGRESS NOTES
; Starts at initial TIUTYP; goes up hierarchy til it finds entry.
; ---- TIU*1*81 Don't new TIUDAD HERE!
N TIUI,TIUJ
; ---- TIU*1*81 TIUTITLE is killed before missing fld alerts are sent,
; so don't use it here
Q:+$G(TIUTYP)'>0
S TIUI=$O(^TIU(8925.95,"B",+TIUTYP,0))
; ---- If TIUTYP has docmt parameter, get recipients and don't look
; further up:
I +TIUI D Q
. S TIUJ=0
. F S TIUJ=$O(^TIU(8925.95,+TIUI,4,+TIUJ)) Q:+TIUJ'>0 D
. . N TIUDUZ
. . S TIUDUZ=+$G(^TIU(8925.95,+TIUI,4,+TIUJ,0)) Q:+TIUDUZ'>0
. . S TIUY(TIUDUZ)=""
; ---- If none found, try further up
S TIUDAD=$O(^TIU(8925.1,"AD",+TIUTYP,0))
I +TIUDAD D WHOGETS(.TIUY,TIUDAD)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPEVN1 6383 printed Oct 16, 2024@18:43:42 Page 2
TIUPEVN1 ; SLC/JER - Event logger Cont'd ;05/20/10 14:09
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**81,250**;Jun 20, 1997;Build 14
+2 ;
+3 ; ICR #10006 - ^DIC Routine & DIC, DLAYGO, X, & Y local vars
+4 ; #10018 - ^DIE Routine & DIE, DA, DR, DTOUT, & DUOUT local vars
+5 ; #10004 - EN^DIQ Routine & DIC, DA, X, & Y local vars
+6 ; #10015 - EN^DIQ1 Routine & DIC, DIQ, DA, & DR local vars
+7 ; #10081 - SETUP^XQALERT Routine & XQADATA, XQAID, XQAMSG, & XQAROU local vars
+8 ;
FIELDS(EVNTDA,MSG) ; ---- Log missing/incorrect field errors for
+1 ; specific fields in UPLOAD LOG file (#8925.4),
+2 ; in multiple fl. TIU*1*81 moved from TIUPEVNT
+3 NEW TIUI
SET TIUI=0
+4 FOR
SET TIUI=$ORDER(MSG("DIERR",TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+5 NEW DA,DR,DIC,DIE,DLAYGO,X,Y
SET DIC="^TIU(8925.4,"_EVNTDA_",1,"
SET DIC(0)="L"
+6 IF '$DATA(MSG("DIERR",TIUI,"PARAM","FILE"))
QUIT
+7 SET ^TIU(8925.4,EVNTDA,1,0)="^8925.42^^"
SET DA(1)=EVNTDA
+8 SET DLAYGO=8925.42
SET X=""""_MSG("DIERR",TIUI,"PARAM","FILE")_""""
+9 DO ^DIC
if +Y'>0
QUIT
+10 SET DIE=DIC
SET DA(1)=EVNTDA
SET DA=+Y
+11 SET DR=".02///"_+$GET(MSG("DIERR",TIUI,"PARAM","IENS"))_";.03///"_$GET(MSG("DIERR",TIUI,"PARAM","FIELD"))_";.04///"_$GET(MSG("DIERR",TIUI,"PARAM",3))
+12 DO ^DIE
DO FLDALRT(EVNTDA,DA,$PIECE($GET(^TIU(8925.4,+EVNTDA,0)),U,4))
End DoDot:1
+13 QUIT
FLDALRT(EVNTDA,EVNTDA1,ERRMSG) ; ---- Send alerts for missing field errors
+1 ; TIU*1*81 moved from TIUPEVNT
+2 NEW XQA,XQAID,XQADATA,XQAMSG,XQAKILL,XQAROU,TIUI,TIUSUB,TYPE,EVNTDA10
+3 NEW NOTEDA,NOTE0
+4 ; ---- TIU*1*81 If this is a TIU docmt, get its title for TYPE
+5 SET EVNTDA10=$GET(^TIU(8925.4,EVNTDA,1,EVNTDA1,0))
+6 IF $PIECE(EVNTDA10,U)=8925
Begin DoDot:1
+7 SET NOTEDA=$PIECE(EVNTDA10,U,2)
SET NOTE0=$GET(^TIU(8925,NOTEDA,0))
SET TYPE=+NOTE0
+8 ; ---- TIU*1*81 If note is addendum, get type of parent note instead
+9 IF +$$ISADDNDM^TIULC1(NOTEDA)
SET TYPE=+$$DADTYPE^TIUPUTC(NOTEDA)
End DoDot:1
+10 ; ---- else get TYPE from $HDR line, e.g. Progress Notes (3)
+11 IF $GET(TYPE)'>0
SET TYPE=+$GET(TIUREC("TYPE"))
+12 IF TYPE
DO WHOGETS^TIUPEVN1(.XQA,TYPE)
+13 ; ---- If no docmt def param recipients found, try site recipients
+14 IF $DATA(XQA)'>9
Begin DoDot:1
+15 SET TIUI=$ORDER(^TIU(8925.99,"B",+$GET(DUZ(2)),0))
if +TIUI'>0
SET TIUI=+$ORDER(^TIU(8925.99,0))
+16 SET TIUSUB=0
FOR
SET TIUSUB=$ORDER(^TIU(8925.99,+TIUI,2,TIUSUB))
if TIUSUB'>0
QUIT
Begin DoDot:2
+17 SET XQA($GET(^TIU(8925.99,+TIUI,2,TIUSUB,0)))=""
End DoDot:2
End DoDot:1
+18 if $DATA(XQA)'>9
QUIT
+19 SET XQAID="TIUERR"_","_EVNTDA_","_EVNTDA1
+20 SET XQAMSG=ERRMSG
+21 if '$DATA(ZTQUEUED)
WRITE !!,XQAMSG
+22 SET XQADATA=ERRMSG_";"_EVNTDA_";"_EVNTDA1
+23 ; TIU*1*81 moved from TIUPEVNT
SET XQAROU="FLDISP^TIUPEVN1"
+24 DO SETUP^XQALERT
+25 QUIT
FLDISP ; ---- Alert follow-up action for missing field errors
+1 ; TIU*1*81 moved from TIUPEVNT
+2 NEW DIE,DA,DR,EVNTDA,EVNTDA1,EVNTREC,TIUFIX,TIULINK
SET TIUFIX=0
+3 SET EVNTDA=+$PIECE(XQADATA,";",2)
SET EVNTDA1=+$PIECE(XQADATA,";",3)
+4 SET EVNTREC=$GET(^TIU(8925.4,EVNTDA,1,EVNTDA1,0))
if +EVNTREC'>0
QUIT
+5 SET DIE=$PIECE(EVNTREC,U)
SET DA=$PIECE(EVNTREC,U,2)
+6 SET DR=$PIECE(EVNTREC,U,3)_"//"_$PIECE(EVNTREC,U,4)
+7 SET TIUFIX=$$FIXED(DIE,+DA,+DR)
+8 IF +TIUFIX>0
Begin DoDot:1
+9 if TIUFIX=1
WRITE !!,"Missing field already filled in by another method..."
+10 if TIUFIX=2
WRITE !!,"Record #",DA," has been deleted by an authorized user..."
+11 WRITE !," Nothing left to resolve."
HANG 3
+12 SET XQAKILL=0
DO FLDRSLV(EVNTDA)
End DoDot:1
QUIT
+13 WRITE !!,"You may now enter the correct information:",!
+14 WRITE !,$PIECE(XQADATA,";"),!
+15 DO RECDISP(DIE,DA)
+16 IF DIE=8925
IF (+DR=1405)
Begin DoDot:1
+17 NEW TIUREASX,TIUDA
+18 SET TIUDA=+DA
+19 SET TIUREASX=$$REASSIGN^TIULC1(+$GET(^TIU(8925,+TIUDA,0)))
+20 IF TIUREASX]""
XECUTE TIUREASX
SET TIULINK=1
End DoDot:1
+21 IF '+$GET(TIULINK)
DO ^DIE
+22 ; ---- If TIU Document, do post-filing action send signature alerts
+23 IF DIE="^TIU(8925,"
Begin DoDot:1
+24 NEW TIUREC,TIUPOST,DR,DIE,TYPE,TIUD12,TIUD13,TIUEBY,TIUAU,TIUEC
+25 SET TYPE=$SELECT(+$$ISADDNDM^TIULC1(DA):+$GET(^TIU(8925,+$PIECE(^TIU(8925,DA,0),U,6),0)),1:+$GET(^TIU(8925,DA,0)))
+26 SET TIUPOST=$$POSTFILE^TIULC1(TYPE)
+27 SET TIUREC("#")=DA
+28 IF TIUPOST]""
XECUTE TIUPOST
IF 1
+29 ;if not entered by the author or expected cosigner record VBC Line Count
+30 SET TIUD12=$GET(^TIU(8925,DA,12))
SET TIUD13=$GET(^(13))
+31 SET TIUEBY=$PIECE(TIUD13,U,2)
SET TIUAU=$PIECE(TIUD12,U,2)
SET TIUEC=$PIECE(TIUD13,U,8)
+32 IF ((+TIUEBY>0)&(+TIUAU>0))&((TIUEBY'=TIUAU)&(TIUEBY'=TIUEC))
DO LINES^TIUSRVPT(DA)
+33 DO SEND^TIUALRT(DA)
End DoDot:1
+34 SET TIUFIX=$$FIXED(DIE,+DA,+DR)
+35 IF +$GET(TIUFIX)'>0
KILL XQAKILL
QUIT
+36 SET XQAKILL=0
+37 ; ---- If field is fixed, evaluate whether whole event is resolved
+38 DO FLDRSLV(EVNTDA)
+39 QUIT
RECDISP(DIC,DA) ; ---- Call DIQ to display the existing record
+1 ; TIU*1*81 moved from TIUPEVNT
+2 NEW X,Y,DIQ,DR
+3 IF '+$$READ^TIUU("Y","Display ENTIRE existing record","NO")
QUIT
+4 WRITE !
SET DIC=$GET(^DIC(DIC,0,"GL"))
+5 DO EN^DIQ
+6 QUIT
FIXED(DIC,DA,DR) ; ---- Evaluate whether the field has been filled in
+1 ; TIU*1*81 moved from TIUPEVNT
+2 NEW DIQ,X,Y,TIUY,TIUFIX
SET TIUY=0
SET DIQ="TIUFIX"
SET DIQ(0)="IN"
+3 IF '$DATA(^TIU(8925,DA,0))
SET TIUY=2
GOTO FIXX
+4 DO EN^DIQ1
IF $DATA(TIUFIX)
SET TIUY=1
FIXX QUIT TIUY
FLDRSLV(ERRDA) ; ---- Evaluate missing field errors; mark resolved
+1 ; TIU*1*81 moved from TIUPEVNT
+2 NEW TIUK,TIUFLD,RSLVED
+3 SET TIUK=0
SET RSLVED=1
+4 ; ---- TIU*1*81 Mark resolved only if ALL missing fields are fixed
+5 FOR
SET TIUK=$ORDER(^TIU(8925.4,+ERRDA,1,TIUK))
if +TIUK'>0
QUIT
if 'RSLVED
QUIT
Begin DoDot:1
+6 NEW DIC,DIQ,DA,DR
SET DA=TIUK
SET DIC="^TIU(8925.4,"_+ERRDA_",1,"
+7 SET DR=".01:.04"
SET DIQ="TIUFLD("
DO EN^DIQ1
if $DATA(TIUFLD)'>9
QUIT
+8 IF '$$FIXED(8925,+$GET(TIUFLD(8925.42,DA,.02)),+$GET(TIUFLD(8925.42,DA,.03)))=1
SET RSLVED=0
End DoDot:1
+9 if 'RSLVED
QUIT
+10 NEW DIE,DR
+11 SET DA=+ERRDA
SET DIE=8925.4
SET DR=".06////1;.07////"_$$NOW^TIULC
DO ^DIE
+12 QUIT
+13 ;
WHOGETS(TIUY,TIUTYP) ; ---- Who gets filing error/missing field alerts;
+1 ; Get 8925.95 (document parameter) recipients.
+2 ; ---- TIUTYP is title IFN in 8925.1 if valid title was uploaded, else
+3 ; is IFN of entry from $HDR line: e.g. PROGRESS NOTES
+4 ; Starts at initial TIUTYP; goes up hierarchy til it finds entry.
+5 ; ---- TIU*1*81 Don't new TIUDAD HERE!
+6 NEW TIUI,TIUJ
+7 ; ---- TIU*1*81 TIUTITLE is killed before missing fld alerts are sent,
+8 ; so don't use it here
+9 if +$GET(TIUTYP)'>0
QUIT
+10 SET TIUI=$ORDER(^TIU(8925.95,"B",+TIUTYP,0))
+11 ; ---- If TIUTYP has docmt parameter, get recipients and don't look
+12 ; further up:
+13 IF +TIUI
Begin DoDot:1
+14 SET TIUJ=0
+15 FOR
SET TIUJ=$ORDER(^TIU(8925.95,+TIUI,4,+TIUJ))
if +TIUJ'>0
QUIT
Begin DoDot:2
+16 NEW TIUDUZ
+17 SET TIUDUZ=+$GET(^TIU(8925.95,+TIUI,4,+TIUJ,0))
if +TIUDUZ'>0
QUIT
+18 SET TIUY(TIUDUZ)=""
End DoDot:2
End DoDot:1
QUIT
+19 ; ---- If none found, try further up
+20 SET TIUDAD=$ORDER(^TIU(8925.1,"AD",+TIUTYP,0))
+21 IF +TIUDAD
DO WHOGETS(.TIUY,TIUDAD)
+22 QUIT
