Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIU199

TIU199.m

Go to the documentation of this file.
  1. TIU199 ;BP/JML - TIU Alert Fix Tool ; 7/6/05 4:06pm
  1. ;;1.0;TEXT INTEGRATION UTILITIES;**199**;Jun 20, 1997
  1. ;
  1. Q
  1. 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
  1. N TIU0,TIUSET,TIUDOC,TIUEXP,FDA
  1. S TIUEXP=$P($G(^TIU(8925.7,DA,0)),"^",3),TIUSET=0
  1. I $$ISSURFOR^TIUADSIG(X,TIUEXP) S TIUSET=1
  1. S FDA(8925.7,DA_",",.09)=TIUSET
  1. D FILE^DIE("","FDA","TIUERR")
  1. Q
  1. ;
  1. EN ; MAIN DRIVER
  1. N DIC,TIUPERS,TIUDTS,TIUCSTAT,TIUQ,DTOUT,DUOUT,Y,TIUNAME
  1. D CLEAR^VALM1
  1. S DIC="^VA(200,",DIC(0)="AEMQ"
  1. S DIC("A")="Select ADDITIONAL SIGNER: "
  1. D ^DIC S TIUPERS=+Y,TIUNAME=$P(Y,"^",2)
  1. Q:$G(DTOUT)!($G(DUOUT))!(Y=-1)
  1. D DTRANGE^TIUADCL(.TIUDTS)
  1. Q:'$G(TIUDTS("BEGDT"))!('$G(TIUDTS("ENDDT")))
  1. S TIUCSTAT=$O(^TIU(8925.6,"B","COMPLETED",""))
  1. D GATHER
  1. S TIUQ=0
  1. LOOP ;
  1. I '$D(^TMP($J)) S TIUQ=$$NODATA()
  1. I $D(^TMP($J)) D
  1. .D PRINT
  1. .S TIUQ=$$PROMPT()
  1. ; TIUQ: 0=LOOP ON EXISTING BUILD, 2=CREATE NEW SEARCH/BUILD, 1=QUIT ENTIRELY
  1. I TIUQ=0 G LOOP
  1. I TIUQ=2 G EN
  1. K ^TMP($J)
  1. Q
  1. ;
  1. GATHER ; COLLECT DATA BASED ON SEARCH CRITERIA
  1. N TIUNOTE,TIUCNT,TIUADD,TIUAIEN,TIUA0,TIU0,TIUSTAT,TIU13,TIURFDT,TIUDTYP,TIUDFN,TIUPAT
  1. K ^TMP($J)
  1. S TIUNOTE="",TIUCNT=1
  1. F S TIUNOTE=$O(^TIU(8925.7,"AE",TIUNOTE)) Q:TIUNOTE="" D
  1. .S TIUADD=""
  1. .F S TIUADD=$O(^TIU(8925.7,"AE",TIUNOTE,TIUADD)) Q:TIUADD="" D
  1. ..Q:TIUPERS'=TIUADD
  1. ..S TIUAIEN=""
  1. ..F S TIUAIEN=$O(^TIU(8925.7,"AE",TIUNOTE,TIUADD,TIUAIEN)) Q:TIUAIEN="" D
  1. ...S TIUA0=$G(^TIU(8925.7,TIUAIEN,0))
  1. ...Q:$P(TIUA0,"^",5)="" ; QUIT IF NOT SIGNED AT ALL
  1. ...Q:$P(TIUA0,"^",3)=$P(TIUA0,"^",5) ; QUIT IF EXPECTED AND ACTUAL ARE SAME
  1. ...Q:+$P(TIUA0,"^",9)=1 ; QUIT IF ALRADY MARKED AS 'SIGNED BY SURROGATE'
  1. ...S TIU0=$G(^TIU(8925,TIUNOTE,0))
  1. ...S TIUSTAT=$P(TIU0,"^",5)
  1. ...Q:TIUSTAT'=TIUCSTAT ; QUIT IF NOT IN COMPLETED STATUS
  1. ...S TIU13=$G(^TIU(8925,TIUNOTE,13))
  1. ...S TIURFDT=$P($P(TIU13,"^"),".")
  1. ...Q:TIURFDT<TIUDTS("BEGDT")!(TIURFDT>TIUDTS("ENDDT")) ; QUIT IF NOT IN DT RANGE
  1. ...S TIUDTYP=$P(TIU0,"^"),TIUDFN=$P(TIU0,"^",2)
  1. ...S TIUPAT=$$GETPAT(TIUDFN)
  1. ...S ^TMP($J,TIUCNT)=TIUAIEN_"^"_TIUPAT_"^"_TIUDTYP_"^"_TIURFDT
  1. ...S TIUCNT=TIUCNT+1
  1. Q
  1. ;
  1. PRINT ;
  1. N TIUCNT,TIUDATA,TIUTYP,TIURFDT
  1. D HEAD
  1. S TIUCNT=""
  1. F S TIUCNT=$O(^TMP($J,TIUCNT)) Q:TIUCNT="" D
  1. .S TIUDATA=^TMP($J,TIUCNT)
  1. .S TIUTYP=$P($G(^TIU(8925.1,$P(TIUDATA,"^",4),0)),"^")
  1. .S Y=$P(TIUDATA,"^",5) D DD^%DT S TIURFDT=Y
  1. .W !,TIUCNT,?5,$E($P(TIUDATA,"^",2),1,15),?22,"("_$P(TIUDATA,"^",3)_")",?31,$E(TIUTYP,1,25),?58,TIURFDT
  1. Q
  1. ;
  1. PROMPT() ; PROMPT BASED ON DATA IN ^TMP($J) - QUIT VALUE DETERMINES FLOW IN LOOP/EN LINE TAGS
  1. N X,TIUAIEN,DIR,DIRUT,FDA
  1. W !
  1. S DIR("A")="'NEW' FOR A NEW SEARCH OR '^' TO QUIT"
  1. S DIR("A",1)="ENTER SEQUENCE # TO MARK AS 'SIGNED BY SURROGATE',"
  1. S DIR(0)="F"
  1. D ^DIR
  1. ; QUIT CONDITIONS
  1. I $G(DIRUT) Q 1
  1. I X="NEW" Q 2
  1. I '$D(^TMP($J,X)) D Q 0
  1. .W !!,"INVALID CHOICE" D CLEAR^VALM1
  1. ; CHANGE VALUES AND KILL TMP
  1. S TIUAIEN=+^TMP($J,X)
  1. S FDA(8925.7,TIUAIEN_",",.09)=1
  1. D FILE^DIE("","FDA","TIUERR")
  1. K ^TMP($J,X)
  1. I '$D(^TMP($J)) Q 2
  1. Q 0
  1. ;
  1. D CLEAR^VALM1
  1. W "ADDITIONAL SIGNER: ",TIUNAME,!!
  1. W !,"SEQ",?5,"PATIENT",?31,"DOCUMENT TYPE",?58,"REFERENCE DATE"
  1. W !,"---",?5,"-------",?31,"-------------",?58,"--------------"
  1. Q
  1. ;
  1. NODATA() ;
  1. D CLEAR^VALM1
  1. W !!,?15,"NO DATA TO REPORT FOR THIS SEARCH"
  1. N DIRUT,TIUND S TIUND=2
  1. D PAUSE^VALM1
  1. I $G(DIRUT) S TIUND=1
  1. Q TIUND
  1. ;
  1. GETPAT(TIUDFN) ;
  1. N DFN,TIUSSN,TIUPN,VADM
  1. S DFN=TIUDFN
  1. D DEM^VADPT
  1. S TIUSSN=$P(VADM(2),"^")
  1. S TIUPN=VADM(1)_"^"_$E(VADM(1))_$E(TIUSSN,6,$L(TIUSSN))
  1. Q TIUPN
  1. ;
  1. POST199 ; REINDEX THE ABBREVIATION FIELD OF FILE 8925.1
  1. N DIK
  1. S DIK="^TIU(8925.1,",DIK(1)=".02"
  1. D ENALL^DIK
  1. Q