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

BTIURPT3.m

Go to the documentation of this file. 
  1. BTIURPT3 ; IHS/ITSC/LJF - Review documents by Reference Date ;
  1.  ;;1.0;TEXT INTEGRATION UTILITIES;;NOV 04, 2004
  1.  ; Copy of ^TIURPTTL - IHS Browse docuemnt texts by reference date
  1.  ;   -- used to set up view of all documents for a patient
  1.  ;   -- added IHS fields to display in IHS order
  1.  ;   -- added view check to screen out documents
  1.  ;   -- commented out lines and changed loop to display ALL documents
  1.  ;   -- removed question where user lists which types to display
  1.  ;   -- changed begin date default to T-6M
  1.  ;   -- added check for calls from other packages (tiuzihs)
  1.  ;
  1. MAKELIST(TIUCLASS) ; Get Search Criteria
  1.  N TIUI,SCREEN,STATUS,TIUTYP,TIUSTAT,TIUEDFLT,TIUDCL,TIUQUIT
  1. STATUS S STATUS=$$SELSTAT^TIULA(.TIUSTAT,"F","ALL")
  1.  I +STATUS<0 S VALMQUIT=1 Q
  1. PATIENT ; Select Patient
  1.  ;S DFN=+$$PATIENT^TIULA              ;original VA
  1.  K DFN I $G(TIUZIHS) S DFN=+TIUZIHS   ;check if called by other app
  1.  E  S DFN=+$$PATIENT^TIULA            ;else use VA code
  1.  I +DFN'>0 S VALMQUIT=1 Q
  1. DOCTYPE ; Select Document Type(s)
  1.  ;commented out VA code so search is done on all documents
  1.  ;N TIUDCL
  1.  ;D TITLPICK^TIULA3(.TIUTYP,TIUCLASS)
  1.  ;I +$D(TIUQUIT) S VALMQUIT=1 Q
  1.  ;I +$G(TIUTYP)'>0,'$D(TIUQUIK) G STATUS
  1. SCREEN ;
  1.  N TIUNAME
  1.  S TIUNAME=$P($G(^VA(200,+DUZ,0)),U)
  1.  S SCREEN=1,SCREEN(1)="APT^"_DFN
  1.  ;D CHECKADD(.TIUTYP)                   ;original VA - always include addendums
  1. ERLY ;S TIUEDFLT=$S(TIUCLASS=3:"T-2",TIUCLASS=244:"T-30",1:"T-7")   ;original VA
  1.  S TIUEDFLT="T-6M"                                              ;default now 6 months
  1.  S TIUEDT=$S($D(TIUQUIK):1,1:$$EDATE^TIULA("Reference","",TIUEDFLT))
  1.  I +$G(DIROUT) S VALMQUIT=1 Q
  1.  I TIUEDT'>0 G SCREEN
  1.  S TIULDT=$S($D(TIUQUIK):9999999,1:$$LDATE^TIULA("Reference"))
  1.  I +$G(DIROUT) S VALMQUIT=1 Q
  1.  I TIULDT'>0 G ERLY
  1.  W !,"Searching for the documents."
  1.  D BUILD(.TIUSTAT,.TIUTYP,.SCREEN,TIUEDT,TIULDT)
  1.  Q
  1. CHECKADD(TYPES) ; Checks whether Addendum is included in the list of types
  1.  N TIUI,HIT S (TIUI,HIT)=0
  1.  F  S TIUI=$O(TYPES(TIUI)) Q:+TIUI'>0!+HIT  I $$UP^XLFSTR(TYPES(TIUI))["ADDENDUM" S HIT=1
  1.  I +HIT'>0 S TYPES(TYPES+1)=+TYPES(TYPES)+1_U_"81^Addendum^NOT PICKED",TYPES=TYPES+1
  1.  Q
  1. BUILD(STATUS,TYPES,SCREEN,EARLY,LATE) ; Build List
  1.  N TIUCNT,TIUDT,TIUI,TIUJ,TIUK,TIUP,TIUQ,TIUIFN,TIUREC
  1.  N TIUT,TIUTP,XREF,TIUS,TIUPREF
  1.  S TIUPREF=$$PERSPRF^TIULE(DUZ),(TIUK,VALMCNT)=0
  1.  K ^TMP("TIUR",$J),^TMP("TIURIDX",$J),^TMP("TIUI",$J)
  1.  K ^TMP("TIURIHS",$J) S (TIUZLN,TIUZCNT)=0             ;added code
  1.  I '$D(TIUPRM0)!'$D(TIUPRM0) D SETPARM^TIULE
  1.  S EARLY=9999999-+$G(EARLY),LATE=9999999-$S(+$G(LATE):+$G(LATE),1:3333333)
  1.  F  S TIUK=$O(SCREEN(TIUK)) Q:TIUK'>0  D
  1.  . S XREF=$P(SCREEN(TIUK),U)
  1.  . I XREF'="ASUB" D
  1.  . . S TIUI=$S(XREF'="APRB":$P(SCREEN(TIUK),U,2),1:$$UPPER^TIULS($P(SCREEN(TIUK),U,3)))
  1.  . . D GATHER(TIUI,TIUPREF,TIUCLASS)
  1.  . I XREF="ASUB" D
  1.  . . S TIUI=$O(^TIU(8925,XREF,$P(SCREEN(TIUK),U,2)),-1)
  1.  . . F  S TIUI=$O(^TIU(8925,XREF,TIUI)) Q:TIUI=""!(TIUI'[$P(SCREEN(TIUK),U,2))  D GATHER(TIUI,TIUPREF,TIUCLASS)
  1.  D PUTLIST(TIUPREF)
  1.  S ^TMP("TIUR",$J,"RTN")="TIUROR"  ;rebuild routine
  1.  Q
  1. GATHER(TIUI,TIUPREF,CLASS) ; Find/sort records for the list
  1.  N TIUT,TIUTP,TIUS,TIUSTAT,TIUSFLD,TIUD0,TIUD12,TIUD13,TIUD15
  1.  N TIUSVAL
  1.  ;S TIUSFLD=$P(TIUPREF,U,3)      ;original VA
  1.  ;S TIUSFLD=$S(TIUSFLD="P":".02",TIUSFLD="D":".01",TIUSFLD="S":".05",TIUSFLD="C":"1507",TIUSFLD="A":"1202",TIUSFLD="E":"1208",1:"1301") ;original VA
  1.  S TIUSFLD="1301"                ;sort by reference date
  1.  ;
  1.  ;S TIUT=0 F  S TIUT=$O(TYPES(TIUT)) Q:+TIUT'>0  D       ;original VA
  1.  ;. S TIUTP=+$P($G(TYPES(TIUT)),U,2) Q:TIUTP'>0          ;original VA
  1.  S TIUT=0 F  S TIUT=$O(^TIU(8925.1,TIUT)) Q:'TIUT  D     ;loop thru all documents
  1.  . S TIUTP=TIUT                                          ;set variable correctly
  1.  . ;
  1.  . S TIUS=0 F  S TIUS=$O(STATUS(TIUS)) Q:+TIUS'>0  D
  1.  . . S TIUSTAT=$O(^TIU(8925.6,"B",$$UPPER^TIULS($P(STATUS(TIUS),U,3)),0))
  1.  . . Q:+TIUSTAT'>0
  1.  . . S TIUJ=LATE F  S TIUJ=$O(^TIU(8925,XREF,TIUI,TIUTP,TIUSTAT,TIUJ)) Q:+TIUJ'>0!(+TIUJ>EARLY)  D
  1.  . . . S TIUIFN=0
  1.  . . . F  S TIUIFN=$O(^TIU(8925,XREF,TIUI,TIUTP,TIUSTAT,TIUJ,TIUIFN)) Q:+TIUIFN'>0  D
  1.  . . . . ;I TIUTP=81,(+TYPES>1),($P(TYPES(TIUT),U,4)="NOT PICKED"),'+$$DADINTYP(TIUIFN,.TYPES) Q ;original VA-don't screen out addendums
  1.  . . . . S TIUQ=$$RESOLVE(TIUIFN,TIUSFLD)
  1.  . . . . S ^TMP("TIUI",$J,TIUQ,TIUJ,TIUIFN)=""
  1.  Q
  1. DADINTYP(TIUDA,TYPES) ; Evaluates whether addendum's parent belongs is among
  1.  ;                 the selected types
  1.  N TIUI,TIUDTYP,TIUY S (TIUI,TIUY)=0
  1.  S TIUDTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))
  1.  F  S TIUI=$O(TYPES(TIUI)) Q:+TIUI'>0!+TIUY  D
  1.  . I +$P(TYPES(TIUI),U,2)=TIUDTYP S TIUY=1
  1.  Q TIUY
  1. RESOLVE(DA,DR) ; Call DIQ1 to resolve field values
  1.  N DIC,DIQ,X,Y,TIUY S DIC=8925,DIQ="TIUY",DIQ(0)="IE"
  1.  I DR=1507,($P($G(^TIU(8925,DA,0)),U,5)=7),(+$P($G(^TIU(8925,DA,15)),U,7)'>0) S DR=1501
  1.  D EN^DIQ1
  1.  I $D(TIUY) D
  1.  . S TIUY=$S((DR=.05)!(DR=1301)!(DR=1501)!(DR=1507):$G(TIUY(8925,DA,DR,"I")),1:$G(TIUY(8925,DA,DR,"E")))
  1.  I TIUY']"" S TIUY="ZZZZEMPTY"
  1.  Q TIUY
  1. PUTLIST(TIUPREF) ; Expands list elements for LM Template
  1.  N TIUJ,TIUQ,TIUDA,TIUPICK,TIUORDER
  1.  S TIUORDER=$S($P(TIUPREF,U,4)="D":-1,1:1)
  1.  S TIUPICK=+$O(^ORD(101,"B","TIU ACTION SELECT LIST ELEMENT",0))
  1.  S TIUQ="" F  S TIUQ=$O(^TMP("TIUI",$J,TIUQ),TIUORDER) Q:TIUQ']""  D
  1.  . S TIUJ=0 F  S TIUJ=$O(^TMP("TIUI",$J,TIUQ,TIUJ)) Q:+TIUJ'>0  D
  1.  . . S TIUDA=0 F  S TIUDA=$O(^TMP("TIUI",$J,TIUQ,TIUJ,TIUDA)) Q:+TIUDA'>0  D ADDELMNT(TIUDA,.TIUCNT)
  1.  S TIUS=1,STATUS=$$UPPER^TIULS($P(STATUS(1),U,3))
  1.  I +$G(STATUS(4))'>0 F  S TIUS=$O(STATUS(TIUS)) Q:+TIUS'>0  D
  1.  . S STATUS=STATUS_$S(TIUS=+STATUS(1):" & ",1:", ")_$$UPPER^TIULS($P(STATUS(TIUS),U,3))
  1.  I +$G(STATUS(4))>0 S STATUS=$S($P(STATUS(4),U,4)="ALL":"ALL",1:STATUS_" & OTHER")
  1.  S ^TMP("TIUR",$J,0)=+$G(TIUCNT)_U_STATUS
  1.  S TIUJ=0,SCREEN="" F  S TIUJ=$O(SCREEN(TIUJ)) Q:+TIUJ'>0  D
  1.  . S SCREEN=$G(SCREEN)_$S(TIUJ>1:";",1:U)_SCREEN(TIUJ)
  1.  S ^TMP("TIUR",$J,0)=^TMP("TIUR",$J,0)_$G(SCREEN)
  1.  S ^TMP("TIUR",$J,"CLASS")=TIUCLASS
  1.  S ^TMP("TIUR",$J,"#")=TIUPICK_"^1:"_+$G(TIUCNT)
  1.  ;I $D(VALMHDR)>9 D HDR^TIURH           ;original VA
  1.  I $D(VALMHDR)>9 D HDR^BTIURPT          ;use IHS header
  1.  I +$G(TIUCNT)'>0 D
  1.  . S ^TMP("TIUR",$J,1,0)="",VALMCNT=2
  1.  . S ^TMP("TIUR",$J,2,0)="     No records found to satisfy search criteria."
  1.  Q
  1. ADDELMNT(DA,TIUCNT,APPEND) ; Add each element to the list
  1.  N DIC,DIQ,DR,TIUR,PT,MOM,ADT,DDT,LCT,AUT,AMD,EDT,SDT,XDT,RMD,TIULST4
  1.  I $G(^TMP("TIUR",$J,2,0))="     No records found to satisfy search criteria." D
  1.  . S ^TMP("TIUR",$J,2,0)="",VALMCNT=0
  1.  S DIQ="TIUR",DIC=8925,DIQ(0)="IE"
  1.  S DR=".01;.02;.05;.07;.08;1202;1301;1204;1208;1501;1507" D EN^DIQ1
  1.  S DOC=$$PNAME^TIULC1(+TIUR(8925,DA,.01,"I"))
  1.  I DOC="Addendum" S DOC=DOC_" to "_$$PNAME^TIULC1(+$G(^TIU(8925,+$P(^TIU(8925,+DA,0),U,6),0)))
  1.  S PT=$$NAME^TIULS(TIUR(8925,DA,.02,"E"),"LAST,FI MI")
  1.  I +$O(^TIU(8925,"DAD",+DA,0)),$$HASADDEN^TIULC1(DA) S PT="+ "_PT
  1.  S TIUP=$$URGENCY(+DA)
  1.  S:TIUP=1 PT=$S(PT["+":"*",1:"* ")_PT
  1.  S TIULST4=$E($P($G(^DPT(TIUR(8925,DA,.02,"I"),0)),U,9),6,9)
  1.  S TIULST4="("_$E(TIUR(8925,DA,.02,"E"))_TIULST4_")"
  1.  S ADT=$$DATE^TIULS(TIUR(8925,DA,.07,"I"),"MM/DD/YY")
  1.  S DDT=$$DATE^TIULS(TIUR(8925,DA,.08,"I"),"MM/DD/YY")
  1.  S AMD=$$NAME^TIULS(TIUR(8925,DA,1208,"E"),"LAST, FI MI")
  1.  S AUT=$$NAME^TIULS(TIUR(8925,DA,1202,"E"),"LAST, FI MI")
  1.  S EDT=$$DATE^TIULS(TIUR(8925,DA,1301,"I"),"MM/DD/YY")
  1.  S SDT=$S(+TIUR(8925,DA,1507,"I"):TIUR(8925,DA,1507,"I"),TIUR(8925,DA,.05,"I")'<7:+TIUR(8925,DA,1501,"I"),1:"")
  1.  S SDT=$$DATE^TIULS(SDT,"MM/DD/YY")
  1.  S TIUCNT=+$G(TIUCNT)+1
  1.  ;
  1.  ;commented out code for VA fields
  1.  ;S TIUREC=$$SETFLD^VALM1(TIUCNT,"","NUMBER")
  1.  ;S TIUREC=$$SETFLD^VALM1($$LOWER^TIULS(TIUR(8925,DA,.05,"E")),TIUREC,"STATUS")
  1.  ;S TIUREC=$$SETFLD^VALM1(TIULST4,TIUREC,"LAST I/LAST 4")
  1.  ;S TIUREC=$$SETFLD^VALM1(PT,TIUREC,"PATIENT NAME")
  1.  ;S TIUREC=$$SETFLD^VALM1(DOC,TIUREC,"DOCUMENT TYPE")
  1.  ;S TIUREC=$$SETFLD^VALM1(ADT,TIUREC,"ADMISSION DATE")
  1.  ;S TIUREC=$$SETFLD^VALM1(EDT,TIUREC,"REF DATE")
  1.  ;S TIUREC=$$SETFLD^VALM1(SDT,TIUREC,"SIG DATE")
  1.  ;S TIUREC=$$SETFLD^VALM1(AUT,TIUREC,"AUTHOR")
  1.  ;S TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"COSIGNER")
  1.  ;
  1.  D NOTES^BTIURPT(DA,"R")    ; IHS call to display docuemnt text
  1.  ;
  1.  ;S VALMCNT=+$G(VALMCNT)+1,^TMP("TIUR",$J,TIUCNT,0)=TIUREC        ;original VA
  1.  S VALMCNT=+TIUZLN                                                ;set line # correctly
  1.  ;S ^TMP("TIUR",$J,"IDX",VALMCNT,TIUCNT)="" W "."                 ;original VA
  1.  S ^TMP("TIURIDX",$J,TIUCNT)=VALMCNT_U_DA
  1.  ;D FLDCTRL^VALM10(TIUCNT,"NUMBER",IOINHI,IOINORM)                ;original VA
  1.  I +$G(APPEND) D
  1.  . D RESTORE^VALM10(TIUCNT)
  1.  . D CNTRL^VALM10(TIUCNT,1,$G(VALM("RM")),IOINHI,IOINORM),HDR^TIURH
  1.  . S VALMSG="** Item #"_TIUCNT_" Added **"
  1.  . S $P(^TMP("TIUR",$J,0),U)=+$G(TIUCNT)
  1.  . S $P(^TMP("TIUR",$J,"#"),":",2)=+$G(TIUCNT)
  1.  . I $D(VALMHDR)>9 D HDR^TIURH
  1.  Q
  1. CLEAN ; Clean up your mess!
  1.  K ^TMP("TIUR",$J),^TMP("TIURIDX",$J) D CLEAN^VALM10
  1.  K VALMY
  1.  K TIUZCNT,TIUZLN         ;clean up IHS variables too
  1.  Q
  1. URGENCY(TIUDA) ;EP - What is the urgency of the current document
  1.  ; called by ^BTIURPT as well as this routine
  1.  N TIUY,TIUD0,TIUDSTAT,TIUDURG
  1.  S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUDSTAT=$P(TIUD0,U,5)
  1.  S TIUDURG=$P(TIUD0,U,9)
  1.  S TIUY=$S(TIUDSTAT<7:$S(TIUDURG="P":1,1:2),1:3)
  1.  Q TIUY
  1. DFLTSTAT(USER) ; Set default STATUS for current user
  1.  N TIUMIS,TIUMD,TIUY,TIUDPRM D DOCPRM^TIULC1(244,.TIUDPRM)
  1.  S TIUMIS=$$ISA^USRLM(DUZ,"MEDICAL INFORMATION SECTION")
  1.  I +TIUMIS,+$P($G(TIUDPRM(0)),U,3) S TIUY="UNVERIFIED" G DFLTX
  1.  I $$ISA^USRLM(DUZ,"PROVIDER") S TIUY="UNSIGNED" G DFLTX
  1.  S TIUY="COMPLETED"
  1. DFLTX Q TIUY
  1.  ;
  1.  ;IHS subrtns added
  1. VSTDT() ; -- returns numdate of visit
  1.  Q $$VSTDT^BTIURPT(DA)
  1.  ;
  1. VSTCAT() ; -- returns service category of visit
  1.  Q $$VSTCAT^BTIURPT(DA)
  1.  ;
  1. VSTDX() ; -- returns prim dx for visit
  1.  Q $$VSTDX^BTIURPT(DA)