- 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 Feb 19, 2025@00:09:37 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