- TIU199 ;BP/JML - TIU Alert Fix Tool ; 7/6/05 4:06pm
- ;;1.0;TEXT INTEGRATION UTILITIES;**199**;Jun 20, 1997
- ;
- 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
- S DFN=TIUDFN
- D DEM^VADPT
- S TIUSSN=$P(VADM(2),"^")
- S TIUPN=VADM(1)_"^"_$E(VADM(1))_$E(TIUSSN,6,$L(TIUSSN))
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIU199 3786 printed Feb 19, 2025@00:04:54 Page 2
- TIU199 ;BP/JML - TIU Alert Fix Tool ; 7/6/05 4:06pm
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**199**;Jun 20, 1997
- +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
- +2 SET DFN=TIUDFN
- +3 DO DEM^VADPT
- +4 SET TIUSSN=$PIECE(VADM(2),"^")
- +5 SET TIUPN=VADM(1)_"^"_$EXTRACT(VADM(1))_$EXTRACT(TIUSSN,6,$LENGTH(TIUSSN))
- +6 QUIT TIUPN
- +7 ;
- 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