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