source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPUTA.m@ 1671

TIUPUTA ; SLC/JER - Utilities for C & P Look-up, etc. ;26-MAY-1999 16:38:37
 ;;1.0;TEXT INTEGRATION UTILITIES;**68**;Jun 20, 1997
LOOKUP ; Look-up code used by router/filer
 ; Required: TIUCPFN, TIUSSN
 N CPDFN,DFN,TIU2507R,TIU25070
 I $S('$D(TIUSSN):1,$G(TIUCPFN)']"":1,$G(TIUSSN)?4N:1,$G(TIUSSN)']"":1,1:0) S Y=-1 G LOOKUPX
 I TIUSSN?3N1P2N1P4N.E S TIUSSN=$TR(TIUSSN,"-/","")
 I TIUSSN["?" S Y=-1 G LOOKUPX
 K TIUHDR(.02)
 ;Confirm that exam is for correct patient
 S DFN=+$$PATIENT^TIULA(TIUSSN)
 S TIU25070=$G(^DVB(396.4,TIUCPFN,0)),TIU2507R=+$P(TIU25070,U,2)
 I TIU2507R'>0 S Y=-1 G LOOKUPX
 S CPDFN=+$G(^DVB(396.3,TIU2507R,0))
 I CPDFN'=DFN S Y=-1 G LOOKUPX
 S Y=$$CALLDIC(TIUCPFN)
LOOKUPX Q
CALLDIC(TIUX) ; Call ^DIC
 N DA,DIC,X,Y
 S DIC=396.4,DIC(0)="NX",X="`"_TIUX D ^DIC
 Q Y
FOLLOWUP(TIUDA) ; Post-filing code for C&P's
 N FDA,FDARR,IENS,FLAGS,TIUMSG,TIU
 S IENS=""""_TIUDA_",""",FDARR="FDA(396.4,"_IENS_")",FLAGS="K"
 S @FDARR@(.04)="C"
 D FILE^DIE(FLAGS,"FDA","TIUMSG")
 Q
FIX ; Filing error resolution code for C&P's
 N %,TIUOUT,AMIEDA,TIUX,TIUPRM0,TIUPRM1,SUCCESS,TIUBUF
 ; -- first, determine the correct 2507 exam record --
 F  D  Q:$D(DUOUT)!$D(DIROUT)!+$G(TIUOUT)
 . N D0,DK,DL,DIC,X,Y,DA,DX,A,S
 . W ! S DIC=396.4,DIC(0)="AEMQ"
 . S DIC("W")="D DICW^TIUPUTA(+Y)"
 . S DIC("A")="Select 2507 EXAM REFERENCE NUMBER: "
 . D ^DIC I +Y'>0 S TIUOUT=1 Q
 . W ! S (DA,AMIEDA)=+Y D EN^DIQ
 . S TIUOUT=$$READ^TIUU("Y","... OK","YES")
 Q:$D(DUOUT)!$D(DIROUT)!+$G(DTOUT)!'+$G(AMIEDA)
 ; -- next, load fields from upload buffer entry --
 S TIUBUF=$S(+$G(XQADATA):+$G(XQADATA),+$G(BUFDA):+$G(BUFDA),1:"")
 D LOADTIUX(.TIUX,TIUBUF)
 ; -- finally, file data in 2507 exam file --
 D ADDTEXT(AMIEDA,.TIUX)
 K TIUX("TEXT")
 D FILE(.SUCCESS,AMIEDA,.TIUX,TIUTYPE)
 S TIUPOST=$$POSTFILE^TIULC1(TIUTYPE)
 S TIUREC("#")=AMIEDA
 I TIUPOST]"" X TIUPOST
FIXX D ALERTDEL^TIUPEVNT(+TIUBUF)
 D RESOLVE^TIUPEVNT($S($D(XQADATA):+$P(XQADATA,";",3),1:$G(ERRDA)),1)
 D BUFPURGE^TIUPUTC(+TIUBUF)
 W "Done."
 I +SUCCESS S TIUDONE=1
 Q
DICW(TIUDA) ; Write identifiers
 N X,Y,VADM,VA,VAERR,DVBCP0,DVBCPR0
 S DVBCP0=^DVB(396.4,+TIUDA,0),DVBCPR0=$G(^DVB(396.3,+$P(DVBCP0,U,2),0))
 W ?10,$$NAME^TIULS($$NAME^TIULO(+DVBCPR0),"LAST,FIRST MI")," ",?37,$$SSN^TIULO(+DVBCPR0)," ",?52,$P(^DVB(396.6,+$P(DVBCP0,U,3),0),U,2)
 Q
LOADTIUX(TIUARR,TIUBUF) ; Load TIUX array with header and text
 N TIUI,TIUHSIG,TIUBGN,TIULINE,X,Y,TYPE I '$D(TIUPRM0) D SETPARM^TIULE
 S TIUHSIG=$P(TIUPRM0,U,10),TIUBGN=$P(TIUPRM0,U,12)
 S TIUI=0 F  S TIUI=$O(^TIU(8925.2,+TIUBUF,"TEXT",TIUI)) Q:+TIUI'>0  D
 . S TIULINE=$G(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0))
 . I TIULINE[TIUHSIG D
 . . N TIUD1,TIUD4
 . . S X=$$STRIP^TIULS($P(TIULINE,":",2)),Y=$$WHATYPE^TIUPUTU(X)
 . . I +Y'>0 D MAIN^TIUPEVNT(TIUBUF,1,3,X) Q
 . . S TIUD1=$G(^TIU(8925.1,+Y,1)),TIUD4=$G(^TIU(8925.1,+Y,4))
 . . S TYPE=+Y
 . . F  D  Q:TIULINE[TIUBGN!(+TIUI'>0)
 . . . N TIUN,TIUCAP,TIUFLD,TIUREQ S TIUREQ=0
 . . . S TIUI=$O(^TIU(8925.2,+TIUBUF,"TEXT",TIUI)) Q:+TIUI'>0
 . . . S TIULINE=$G(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0)) Q:TIULINE[TIUBGN
 . . . S TIUCAP=$P(TIULINE,":") Q:TIUCAP']""
 . . . S TIUN=$O(^TIU(8925.1,+TYPE,"HEAD","B",TIUCAP,0))
 . . . Q:+TIUN'>0
 . . . S TIUFLD=$P(^TIU(8925.1,+TYPE,"HEAD",+TIUN,0),U,3)
 . . . Q:TIUFLD']""
 . . . S TIUREQ=$P(^TIU(8925.1,+TYPE,"HEAD",+TIUN,0),U,7)
 . . . S TIUARR(TIUFLD)=$$STRIP^TIULS($P(TIULINE,":",2,99))
 . . . S:TIUFLD'=.001 TIUARR(TIUFLD)=$$TRNSFRM^TIUPEFIX(+TYPE,TIUFLD,TIUARR(TIUFLD))
 . . . I +TIUREQ,TIUARR(TIUFLD)="" S TIUARR(TIUFLD)="** REQUIRED FIELD MISSING FROM UPLOAD **"
 . . . I $S(TIUFLD=.001:1,TIUFLD=.02:1,1:0) K TIUARR(TIUFLD)
 . . I TIULINE[TIUBGN D
 . . . N TIUJ S TIUJ=0
 . . . F  D  Q:+TIUI'>0
 . . . . S TIUI=$O(^TIU(8925.2,+TIUBUF,"TEXT",TIUI)) Q:+TIUI'>0
 . . . . S TIUJ=TIUJ+1
 . . . . S TIUARR("TEXT",TIUJ,0)=$G(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0))
 . . . . S TIUARR("TEXT",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
 Q
ADDTEXT(AMIEDA,TIUX) ; File Text
 N TIUI,TIUJ S TIUI=0,TIUJ=+$P($G(^DVB(396.4,+AMIEDA,"RES",0)),U,3)
 F  S TIUI=$O(TIUX("TEXT",TIUI)) Q:+TIUI'>0  D
 . S TIUJ=TIUJ+1,^DVB(396.4,+AMIEDA,"RES",TIUJ,0)=$G(TIUX("TEXT",TIUI,0))
 . S ^DVB(396.4,+AMIEDA,"RES",0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
 Q
FILE(SUCCESS,AMIEDA,TIUX,RTYPE) ; Call FM Filer to commit updates to DB
 N FDA,FDARR,IENS,FLAGS,TIUMSG
 S IENS=""""_AMIEDA_",""",FDARR="FDA(396.4,"_IENS_")",FLAGS="KE"
 M @FDARR=TIUX
 D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
 I $D(TIUMSG)>9 D
 . S SUCCESS=0_U_$G(TIUMSG(1,"TEXT",1))
 . D MAIN^TIUPEVNT(TIUBUF,2,"",$P($G(^TIU(8925.1,+RTYPE,0)),U),.FDA,.TIUMSG)
 S SUCCESS=AMIEDA
 Q