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

TIUPUTS.m

Go to the documentation of this file. 
  1. TIUPUTS ; SLC/JER - Surgery Look-up, etc. ; 04/19/2004
  1.  ;;1.0;TEXT INTEGRATION UTILITIES;**112,187,173,195,204**;Jun 20, 1997
  1. LOOKUP ; Look-up code used by router/filer
  1.  ; Required: TIUSRCN, TIUSDA, TIUSSN, TIUODT
  1.  N SRODT,DFN,TIUSR0,TIUD0,TIUDAD
  1.  I $S('$D(TIUSSN):1,$G(TIUSSN)?4N:1,$G(TIUSSN)']"":1,+$G(TIUODT)'>0: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.  S DFN=+$$PATIENT^TIULA(TIUSSN)
  1.  I DFN'>0 S Y=-1 G LOOKUPX
  1.  I +$G(TIUSRCN)=0 S TIUSRCN=$$FINDCASE(DFN,+$$IDATE^TIULC(TIUODT))
  1.  I +$G(TIUSRCN)'>0 S Y=-1 G LOOKUPX
  1.  I +$G(TIUSDA)'>0,$D(^SRF(TIUSRCN,"TIU")) S TIUSDA=$$GETSDA(TIUSRCN)
  1.  I +$G(TIUSDA)'>0 D  G LOOKUPX
  1.  . S Y=-1
  1.  . I '$D(^SRF(TIUSRCN,"TIU")),'$D(ZTQUEUED) D
  1.  . . W !!,"Time Out of O.R. has not yet been entered for Surgical Case #",TIUSRCN
  1.  . . W !,"the Surgical Service must complete this step before the Operation"
  1.  . . W !,"Report can be uploaded..."
  1.  K TIUHDR(.001),TIUHDR(.02),TIUHDR(.07),TIUHDR(1405)
  1.  S TIUD0=$G(^TIU(8925,TIUSDA,0)),TIUSR0=$G(^SRF(TIUSRCN,0))
  1.  ;Confirm that SURGICAL CASE is for correct patient
  1.  I +TIUSR0'=DFN S Y=-1 G LOOKUPX
  1.  ;Confirm that TIU DOCUMENT is for correct patient
  1.  I +$P(TIUD0,U,2)'=DFN S Y=-1 G LOOKUPX
  1.  ;Confirm that OPERATION DATE is correct
  1.  I +$$IDATE^TIULC(TIUODT)'=$P($P(TIUSR0,U,9),".") S Y=-1 G LOOKUPX
  1.  S Y=$$CALLDIC(TIUSDA)
  1.  I '+$$CANEDIT(+Y) D
  1.  . W !,"Existing document may not be edited...Creating Addendum."
  1.  . S TIUDAD=+Y,Y=$$MAKEADD^TIUPUTU()
  1.  . D COPYDAD(Y,TIUDAD)
  1. LOOKUPX K TIUSRCN,TIUSDA
  1.  Q
  1. CANEDIT(DA) ; Check whether or not document is released
  1.  Q $S(+$P($G(^TIU(8925,+DA,0)),U,5)<4:1,1:0)
  1. COPYDAD(DA,PARENT) ; copy fixed field data for addenda
  1.  N FDA,FDARR,IENS,FLAGS,TIUMSG,TIUOPDT,TIURDT,TIUD0,TIUD12,TIUD14
  1.  S TIUD0=$G(^TIU(8925,+PARENT,0)),TIUD12=$G(^(12)),TIUD14=$G(^(14))
  1.  S IENS=""""_DA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
  1.  S @FDARR@(.02)=$P(TIUD0,U,2)
  1.  S @FDARR@(.03)=$P(TIUD0,U,3),@FDARR@(.05)=3
  1.  S @FDARR@(.06)=PARENT,@FDARR@(.08)=$P(TIUD0,U,8)
  1.  S @FDARR@(1401)=$P(TIUD14,U)
  1.  S @FDARR@(1402)=$P(TIUD14,U,2)
  1.  S @FDARR@(1405)=TIUSRCN_";SRF("
  1.  S @FDARR@(1201)=$$NOW^TIULC
  1.  S @FDARR@(1205)=$P(TIUD12,U,5)
  1.  S TIUOPDT=+$$IDATE^TIULC($G(TIUODT))
  1.  S TIURDT=$S(+$G(TIUOPDT)>0:+$G(TIUOPDT),1:+$$NOW^XLFDT)
  1.  S @FDARR@(1301)=TIURDT,@FDARR@(1303)="U"
  1.  D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
  1.  Q
  1. FINDCASE(DFN,TIUODT) ; Find Surgical Case for Pt & Dt, if unique
  1.  N TIUY,TIUCN,TIUHIT,TIUPOP S TIUCN="",(TIUY,TIUHIT,TIUPOP)=0
  1.  F  S TIUCN=$O(^SRF("B",DFN,TIUCN),-1) Q:TIUCN'>0!+TIUPOP  D
  1.  . N TIUSR0 S TIUSR0=$G(^SRF(TIUCN,0))
  1.  . I +$G(TIUODT)=$P($P(TIUSR0,U,9),".") D
  1.  . . I +TIUHIT S TIUPOP=1 Q
  1.  . . S TIUHIT=TIUCN
  1.  I 'TIUPOP,TIUHIT S TIUY=TIUHIT
  1.  Q TIUY
  1. GETSDA(TIUSRCN) ; Get Op Report for Case
  1.  N TIUY S TIUY=+$P(^SRF(TIUSRCN,"TIU"),U)
  1.  I 'TIUY S TIUY=+$P(^SRF(TIUSRCN,"TIU"),U,3)
  1.  Q TIUY
  1. CALLDIC(TIUX) ; Call ^DIC to get the IEN for the TIU DOCUMENT
  1.  N DA,DIC,X,Y
  1.  S DIC=8925,DIC(0)="NX",X="`"_TIUX D ^DIC
  1.  Q Y
  1. FOLLOWUP(TIUDA) ; Post-filing code for Operation Reports
  1.  N FDA,FDARR,IENS,FLAGS,TIUMSG,TIU
  1.  S IENS=""""_TIUDA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
  1.  D GETTIU^TIULD(.TIU,TIUDA)
  1.  I $L($G(TIU("EDT"))) S @FDARR@(.07)=$P($G(TIU("EDT")),U)
  1.  S @FDARR@(1204)=$$WHOSIGNS^TIULC1(TIUDA)
  1.  S @FDARR@(1208)=$$WHOCOSIG^TIULC1(TIUDA)
  1.  D FILE^DIE(FLAGS,"FDA","TIUMSG")
  1.  I +$P($G(^TIU(8925,+TIUDA,12)),U,4)'=+$P($G(^(12)),U,9) D
  1.  . S @FDARR@(1506)=1 D FILE^DIE(FLAGS,"FDA","TIUMSG")
  1.  D RELEASE^TIUT(TIUDA,1)
  1.  D AUDIT^TIUEDI1(TIUDA,0,$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")"))
  1.  Q
  1. FIX ; Filing error resolution code for Operation Reports
  1.  N TIUOUT,TIUDA,TIUD0,TIUX,TIUPRM0,TIUPRM1,SUCCESS,TIUBUF,TIUHIT
  1.  N TIUADD,TIUTYP,TIU,DUOUT,DTOUT
  1.  S TIUHIT=0
  1.  ; -- first, determine the correct TIU DOCUMENT record --
  1.  F  D  Q:$D(DUOUT)!$D(DIROUT)!+$G(TIUOUT)
  1.  . N D,D0,DK,DL,DIC,X,Y,DA,DX,A,S,TIUFPRIV
  1.  . S X=+$$PATIENT^TIULA
  1.  . I X'>0 D  Q
  1.  . . W !!,"Okay, no harm done...",!
  1.  . . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1.  . . S TIUOUT=1
  1.  . S DIC=8925,DIC(0)="UXEV",D="C"
  1.  . W !
  1.  . S DIC("W")="D DICW^TIUPUTS(+Y)"
  1.  . S DIC("S")="I +$$DICS^TIUPUTS(+Y)"
  1.  . D IX^DIC
  1.  . I +Y'>0 D  Q
  1.  . . W !!,$S(+$O(^TIU(8925,"C",+X,0))'>0:"No OPERATION REPORTS Available to Update.",1:"No OPERATION REPORT Selected..."),!
  1.  . . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1.  . . S TIUOUT=1
  1.  . W ! S (DA,TIUHIT)=+Y D EN^DIQ
  1.  . S TIUOUT=$$READ^TIUU("Y","... OK","YES") W !
  1.  . I +TIUOUT S TIUDA=DA
  1.  Q:$D(DUOUT)!$D(DIROUT)!+$G(DTOUT)!'+$G(TIUDA)
  1.  ; -- next, load fields from upload buffer entry --
  1.  S TIUBUF=$S(+$G(XQADATA):+$G(XQADATA),+$G(BUFDA):+$G(BUFDA),1:"")
  1.  ; -- if TIUDA may be edited, file data, else make addendum --
  1.  S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUTYP=+TIUD0
  1.  I +$$CANEDIT(TIUDA)'>0 D  G FIXX
  1.  . W !!,"Existing document may not be edited...Creating Addendum.",!
  1.  . D MAKEADD^TIUPEFIX(.TIUADD,TIUDA,TIUBUF)
  1.  . S SUCCESS=TIUADD
  1.  ; -- Load the array TIUX from the buffer
  1.  D LOADTIUX^TIUPEFIX(.TIUX,TIUBUF)
  1.  ; -- finally, file data in TIU DOCUMENT file --
  1.  K ^TIU(8925,+TIUDA,"TEMP"),TIUX(.001),TIUX(.01),TIUX(.02),TIUX(.03),TIUX(.05)
  1.  K TIUX(.13),TIUX(1205),TIUX(1211),TIUX(1405)
  1.  M ^TIU(8925,+TIUDA,"TEMP")=TIUX("TEXT") K TIUX("TEXT")
  1.  D FILE^TIUPEFIX(.SUCCESS,+TIUDA,.TIUX,TIUTYP)
  1.  D GETTIU^TIULD(.TIU,TIUDA)
  1.  D MERGTEXT^TIUEDI1(+TIUDA,.TIU) K ^TIU(8925,TIUDA,"TEMP")
  1.  S TIUPOST=$$POSTFILE^TIULC1(TIUTYP)
  1.  S TIUREC("#")=TIUDA
  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.  S TIUDONE=1
  1.  Q
  1. DICW(TIUDA) ; Write identifiers
  1.  ;VMP OIFO BAY PINES;ELR;TIU*1.0*195;MODIFIED THIS TAG
  1.  N X,Y,VADM,VA,VAERR,TIUD0,TIUD12,TIUD13,TIUD14,TIUPRNM
  1.  S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^(12)),TIUD13=$G(^(13)),TIUD14=$G(^(14))
  1.  W ?35,"Dated: ",$$DATE^TIULS(+TIUD13,"MM/DD/CCYY@HR:MIN"),?62,"By: ",$E($$NAME^TIULS($$PERSNAME^TIULC1(+$P(TIUD12,U,2)),"LAST,FI MI"),1,13)
  1.  ;VMP OIFO BAY PINES;ELR;TIU*1.0*195;ADDED FROM HERE DOWN
  1.  Q:$G(TIUCLASS)'=38
  1.  S TIUD14=+$P(TIUD14,U,5)
  1.  Q:$L(TIUD14)'>0
  1.  D ONE^SROESTV(.TIUPRNM,TIUD14)      ;IA 3533
  1.  N TIUS0 S TIUS0=$G(@TIUPRNM@(TIUD14))
  1.  Q:$L(TIUS0)'>0
  1.  W !?11,"Case #: ",TIUD14,"  ",$P(@TIUPRNM@(TIUD14),U,2)
  1.  Q
  1. DICS(TIUDA) ; Filter IX^DIC list
  1.  N TIUD0,TIUY S TIUY=0
  1.  S TIUD0=$G(^TIU(8925,TIUDA,0))
  1.  I +$$ISA^TIULX(+TIUD0,+$$CLASS^TIUSROI("OPERATION REPORTS")) S TIUY=1 I 1
  1.  E  I +$$ISA^TIULX(+TIUD0,+$$CLASS^TIUSROI("PROCEDURE REPORT (NON-O.R.)")) S TIUY=1
  1.  Q TIUY