TIU199 ;BP/JML - TIU Alert Fix Tool ;25-Apr-2013 14:14;DU
;;1.0;TEXT INTEGRATION UTILITIES;**199,1011**;Jun 20, 1997;Build 13
;
Q
TRIGGER ; trigger code for the .05 field of file 8925.7
; note - do not "NEW" DA or X as these are passed in from FileMan
N TIU0,TIUSET,TIUDOC,TIUEXP,FDA
S TIUEXP=$P($G(^TIU(8925.7,DA,0)),"^",3),TIUSET=0
I $$ISSURFOR^TIUADSIG(X,TIUEXP) S TIUSET=1
S FDA(8925.7,DA_",",.09)=TIUSET
D FILE^DIE("","FDA","TIUERR")
Q
;
EN ; MAIN DRIVER
N DIC,TIUPERS,TIUDTS,TIUCSTAT,TIUQ,DTOUT,DUOUT,Y,TIUNAME
D CLEAR^VALM1
S DIC="^VA(200,",DIC(0)="AEMQ"
S DIC("A")="Select ADDITIONAL SIGNER: "
D ^DIC S TIUPERS=+Y,TIUNAME=$P(Y,"^",2)
Q:$G(DTOUT)!($G(DUOUT))!(Y=-1)
D DTRANGE^TIUADCL(.TIUDTS)
Q:'$G(TIUDTS("BEGDT"))!('$G(TIUDTS("ENDDT")))
S TIUCSTAT=$O(^TIU(8925.6,"B","COMPLETED",""))
D GATHER
S TIUQ=0
LOOP ;
I '$D(^TMP($J)) S TIUQ=$$NODATA()
I $D(^TMP($J)) D
.D PRINT
.S TIUQ=$$PROMPT()
; TIUQ: 0=LOOP ON EXISTING BUILD, 2=CREATE NEW SEARCH/BUILD, 1=QUIT ENTIRELY
I TIUQ=0 G LOOP
I TIUQ=2 G EN
K ^TMP($J)
Q
;
GATHER ; COLLECT DATA BASED ON SEARCH CRITERIA
N TIUNOTE,TIUCNT,TIUADD,TIUAIEN,TIUA0,TIU0,TIUSTAT,TIU13,TIURFDT,TIUDTYP,TIUDFN,TIUPAT
K ^TMP($J)
S TIUNOTE="",TIUCNT=1
F S TIUNOTE=$O(^TIU(8925.7,"AE",TIUNOTE)) Q:TIUNOTE="" D
.S TIUADD=""
.F S TIUADD=$O(^TIU(8925.7,"AE",TIUNOTE,TIUADD)) Q:TIUADD="" D
..Q:TIUPERS'=TIUADD
..S TIUAIEN=""
..F S TIUAIEN=$O(^TIU(8925.7,"AE",TIUNOTE,TIUADD,TIUAIEN)) Q:TIUAIEN="" D
...S TIUA0=$G(^TIU(8925.7,TIUAIEN,0))
...Q:$P(TIUA0,"^",5)="" ; QUIT IF NOT SIGNED AT ALL
...Q:$P(TIUA0,"^",3)=$P(TIUA0,"^",5) ; QUIT IF EXPECTED AND ACTUAL ARE SAME
...Q:+$P(TIUA0,"^",9)=1 ; QUIT IF ALRADY MARKED AS 'SIGNED BY SURROGATE'
...S TIU0=$G(^TIU(8925,TIUNOTE,0))
...S TIUSTAT=$P(TIU0,"^",5)
...Q:TIUSTAT'=TIUCSTAT ; QUIT IF NOT IN COMPLETED STATUS
...S TIU13=$G(^TIU(8925,TIUNOTE,13))
...S TIURFDT=$P($P(TIU13,"^"),".")
...Q:TIURFDT<TIUDTS("BEGDT")!(TIURFDT>TIUDTS("ENDDT")) ; QUIT IF NOT IN DT RANGE
...S TIUDTYP=$P(TIU0,"^"),TIUDFN=$P(TIU0,"^",2)
...S TIUPAT=$$GETPAT(TIUDFN)
...S ^TMP($J,TIUCNT)=TIUAIEN_"^"_TIUPAT_"^"_TIUDTYP_"^"_TIURFDT
...S TIUCNT=TIUCNT+1
Q
;
PRINT ;
N TIUCNT,TIUDATA,TIUTYP,TIURFDT
D HEAD
S TIUCNT=""
F S TIUCNT=$O(^TMP($J,TIUCNT)) Q:TIUCNT="" D
.S TIUDATA=^TMP($J,TIUCNT)
.S TIUTYP=$P($G(^TIU(8925.1,$P(TIUDATA,"^",4),0)),"^")
.S Y=$P(TIUDATA,"^",5) D DD^%DT S TIURFDT=Y
.W !,TIUCNT,?5,$E($P(TIUDATA,"^",2),1,15),?22,"("_$P(TIUDATA,"^",3)_")",?31,$E(TIUTYP,1,25),?58,TIURFDT
Q
;
PROMPT() ; PROMPT BASED ON DATA IN ^TMP($J) - QUIT VALUE DETERMINES FLOW IN LOOP/EN LINE TAGS
N X,TIUAIEN,DIR,DIRUT,FDA
W !
S DIR("A")="'NEW' FOR A NEW SEARCH OR '^' TO QUIT"
S DIR("A",1)="ENTER SEQUENCE # TO MARK AS 'SIGNED BY SURROGATE',"
S DIR(0)="F"
D ^DIR
; QUIT CONDITIONS
I $G(DIRUT) Q 1
I X="NEW" Q 2
I '$D(^TMP($J,X)) D Q 0
.W !!,"INVALID CHOICE" D CLEAR^VALM1
; CHANGE VALUES AND KILL TMP
S TIUAIEN=+^TMP($J,X)
S FDA(8925.7,TIUAIEN_",",.09)=1
D FILE^DIE("","FDA","TIUERR")
K ^TMP($J,X)
I '$D(^TMP($J)) Q 2
Q 0
;
HEAD ;
D CLEAR^VALM1
W "ADDITIONAL SIGNER: ",TIUNAME,!!
W !,"SEQ",?5,"PATIENT",?31,"DOCUMENT TYPE",?58,"REFERENCE DATE"
W !,"---",?5,"-------",?31,"-------------",?58,"--------------"
Q
;
NODATA() ;
D CLEAR^VALM1
W !!,?15,"NO DATA TO REPORT FOR THIS SEARCH"
N DIRUT,TIUND S TIUND=2
D PAUSE^VALM1
I $G(DIRUT) S TIUND=1
Q TIUND
;
GETPAT(TIUDFN) ;
N DFN,TIUSSN,TIUPN,VADM,HRCN
S DFN=TIUDFN
D DEM^VADPT
S TIUSSN=$P(VADM(2),"^")
;IHS/MSC/MGH changed to use HRN
S HRCN=$$HRCN^TIUR2(DFN,+$G(DUZ(2)))
;S TIUPN=VADM(1)_"^"_$E(VADM(1))_$E(TIUSSN,6,$L(TIUSSN))
S TIUPN=VADM(1)_"^"_$E(VADM(1))_HRCN
;IHS/MSC/MGH end mod
Q TIUPN
;
POST199 ; REINDEX THE ABBREVIATION FIELD OF FILE 8925.1
N DIK
S DIK="^TIU(8925.1,",DIK(1)=".02"
D ENALL^DIK
Q
TIU199 ;BP/JML - TIU Alert Fix Tool ;25-Apr-2013 14:14;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**199,1011**;Jun 20, 1997;Build 13
+2 ;
+3 QUIT
TRIGGER ; trigger code for the .05 field of file 8925.7
+1 ; note - do not "NEW" DA or X as these are passed in from FileMan
+2 NEW TIU0,TIUSET,TIUDOC,TIUEXP,FDA
+3 SET TIUEXP=$PIECE($GET(^TIU(8925.7,DA,0)),"^",3)
SET TIUSET=0
+4 IF $$ISSURFOR^TIUADSIG(X,TIUEXP)
SET TIUSET=1
+5 SET FDA(8925.7,DA_",",.09)=TIUSET
+6 DO FILE^DIE("","FDA","TIUERR")
+7 QUIT
+8 ;
EN ; MAIN DRIVER
+1 NEW DIC,TIUPERS,TIUDTS,TIUCSTAT,TIUQ,DTOUT,DUOUT,Y,TIUNAME
+2 DO CLEAR^VALM1
+3 SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
+4 SET DIC("A")="Select ADDITIONAL SIGNER: "
+5 DO ^DIC
SET TIUPERS=+Y
SET TIUNAME=$PIECE(Y,"^",2)
+6 IF $GET(DTOUT)!($GET(DUOUT))!(Y=-1)
QUIT
+7 DO DTRANGE^TIUADCL(.TIUDTS)
+8 IF '$GET(TIUDTS("BEGDT"))!('$GET(TIUDTS("ENDDT")))
QUIT
+9 SET TIUCSTAT=$ORDER(^TIU(8925.6,"B","COMPLETED",""))
+10 DO GATHER
+11 SET TIUQ=0
LOOP ;
+1 IF '$DATA(^TMP($JOB))
SET TIUQ=$$NODATA()
+2 IF $DATA(^TMP($JOB))
Begin DoDot:1
+3 DO PRINT
+4 SET TIUQ=$$PROMPT()
End DoDot:1
+5 ; TIUQ: 0=LOOP ON EXISTING BUILD, 2=CREATE NEW SEARCH/BUILD, 1=QUIT ENTIRELY
+6 IF TIUQ=0
GOTO LOOP
+7 IF TIUQ=2
GOTO EN
+8 KILL ^TMP($JOB)
+9 QUIT
+10 ;
GATHER ; COLLECT DATA BASED ON SEARCH CRITERIA
+1 NEW TIUNOTE,TIUCNT,TIUADD,TIUAIEN,TIUA0,TIU0,TIUSTAT,TIU13,TIURFDT,TIUDTYP,TIUDFN,TIUPAT
+2 KILL ^TMP($JOB)
+3 SET TIUNOTE=""
SET TIUCNT=1
+4 FOR
SET TIUNOTE=$ORDER(^TIU(8925.7,"AE",TIUNOTE))
IF TIUNOTE=""
QUIT
Begin DoDot:1
+5 SET TIUADD=""
+6 FOR
SET TIUADD=$ORDER(^TIU(8925.7,"AE",TIUNOTE,TIUADD))
IF TIUADD=""
QUIT
Begin DoDot:2
+7 IF TIUPERS'=TIUADD
QUIT
+8 SET TIUAIEN=""
+9 FOR
SET TIUAIEN=$ORDER(^TIU(8925.7,"AE",TIUNOTE,TIUADD,TIUAIEN))
IF TIUAIEN=""
QUIT
Begin DoDot:3
+10 SET TIUA0=$GET(^TIU(8925.7,TIUAIEN,0))
+11 ; QUIT IF NOT SIGNED AT ALL
IF $PIECE(TIUA0,"^",5)=""
QUIT
+12 ; QUIT IF EXPECTED AND ACTUAL ARE SAME
IF $PIECE(TIUA0,"^",3)=$PIECE(TIUA0,"^",5)
QUIT
+13 ; QUIT IF ALRADY MARKED AS 'SIGNED BY SURROGATE'
IF +$PIECE(TIUA0,"^",9)=1
QUIT
+14 SET TIU0=$GET(^TIU(8925,TIUNOTE,0))
+15 SET TIUSTAT=$PIECE(TIU0,"^",5)
+16 ; QUIT IF NOT IN COMPLETED STATUS
IF TIUSTAT'=TIUCSTAT
QUIT
+17 SET TIU13=$GET(^TIU(8925,TIUNOTE,13))
+18 SET TIURFDT=$PIECE($PIECE(TIU13,"^"),".")
+19 ; QUIT IF NOT IN DT RANGE
IF TIURFDT<TIUDTS("BEGDT")!(TIURFDT>TIUDTS("ENDDT"))
QUIT
+20 SET TIUDTYP=$PIECE(TIU0,"^")
SET TIUDFN=$PIECE(TIU0,"^",2)
+21 SET TIUPAT=$$GETPAT(TIUDFN)
+22 SET ^TMP($JOB,TIUCNT)=TIUAIEN_"^"_TIUPAT_"^"_TIUDTYP_"^"_TIURFDT
+23 SET TIUCNT=TIUCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
PRINT ;
+1 NEW TIUCNT,TIUDATA,TIUTYP,TIURFDT
+2 DO HEAD
+3 SET TIUCNT=""
+4 FOR
SET TIUCNT=$ORDER(^TMP($JOB,TIUCNT))
IF TIUCNT=""
QUIT
Begin DoDot:1
+5 SET TIUDATA=^TMP($JOB,TIUCNT)
+6 SET TIUTYP=$PIECE($GET(^TIU(8925.1,$PIECE(TIUDATA,"^",4),0)),"^")
+7 SET Y=$PIECE(TIUDATA,"^",5)
DO DD^%DT
SET TIURFDT=Y
+8 WRITE !,TIUCNT,?5,$EXTRACT($PIECE(TIUDATA,"^",2),1,15),?22,"("_$PIECE(TIUDATA,"^",3)_")",?31,$EXTRACT(TIUTYP,1,25),?58,TIURFDT
End DoDot:1
+9 QUIT
+10 ;
PROMPT() ; PROMPT BASED ON DATA IN ^TMP($J) - QUIT VALUE DETERMINES FLOW IN LOOP/EN LINE TAGS
+1 NEW X,TIUAIEN,DIR,DIRUT,FDA
+2 WRITE !
+3 SET DIR("A")="'NEW' FOR A NEW SEARCH OR '^' TO QUIT"
+4 SET DIR("A",1)="ENTER SEQUENCE # TO MARK AS 'SIGNED BY SURROGATE',"
+5 SET DIR(0)="F"
+6 DO ^DIR
+7 ; QUIT CONDITIONS
+8 IF $GET(DIRUT)
QUIT 1
+9 IF X="NEW"
QUIT 2
+10 IF '$DATA(^TMP($JOB,X))
Begin DoDot:1
+11 WRITE !!,"INVALID CHOICE"
DO CLEAR^VALM1
End DoDot:1
QUIT 0
+12 ; CHANGE VALUES AND KILL TMP
+13 SET TIUAIEN=+^TMP($JOB,X)
+14 SET FDA(8925.7,TIUAIEN_",",.09)=1
+15 DO FILE^DIE("","FDA","TIUERR")
+16 KILL ^TMP($JOB,X)
+17 IF '$DATA(^TMP($JOB))
QUIT 2
+18 QUIT 0
+19 ;
HEAD ;
+1 DO CLEAR^VALM1
+2 WRITE "ADDITIONAL SIGNER: ",TIUNAME,!!
+3 WRITE !,"SEQ",?5,"PATIENT",?31,"DOCUMENT TYPE",?58,"REFERENCE DATE"
+4 WRITE !,"---",?5,"-------",?31,"-------------",?58,"--------------"
+5 QUIT
+6 ;
NODATA() ;
+1 DO CLEAR^VALM1
+2 WRITE !!,?15,"NO DATA TO REPORT FOR THIS SEARCH"
+3 NEW DIRUT,TIUND
SET TIUND=2
+4 DO PAUSE^VALM1
+5 IF $GET(DIRUT)
SET TIUND=1
+6 QUIT TIUND
+7 ;
GETPAT(TIUDFN) ;
+1 NEW DFN,TIUSSN,TIUPN,VADM,HRCN
+2 SET DFN=TIUDFN
+3 DO DEM^VADPT
+4 SET TIUSSN=$PIECE(VADM(2),"^")
+5 ;IHS/MSC/MGH changed to use HRN
+6 SET HRCN=$$HRCN^TIUR2(DFN,+$GET(DUZ(2)))
+7 ;S TIUPN=VADM(1)_"^"_$E(VADM(1))_$E(TIUSSN,6,$L(TIUSSN))
+8 SET TIUPN=VADM(1)_"^"_$EXTRACT(VADM(1))_HRCN
+9 ;IHS/MSC/MGH end mod
+10 QUIT TIUPN
+11 ;
POST199 ; REINDEX THE ABBREVIATION FIELD OF FILE 8925.1
+1 NEW DIK
+2 SET DIK="^TIU(8925.1,"
SET DIK(1)=".02"
+3 DO ENALL^DIK
+4 QUIT
