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

TIUPUTA.m

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