source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIU199.m@ 1800

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