- BTIURPT4 ; IHS/ITSC/LJF - Review documents by Reference Date ;
- ;;1.0;TEXT INTEGRATION UTILITIES;;NOV 04, 2004
- ;Copy of ^TIURPTTL - IHS Browse document texts by visit 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 to search 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 ;original VA
- S SCREEN=1,SCREEN(1)="AIHS1^"_DFN ;use IHS visit xref
- ;D CHECKADD(.TIUTYP) ;original VA - don't check addendums
- ERLY ;S TIUEDFLT=$S(TIUCLASS=3:"T-2",TIUCLASS=244:"T-30",1:"T-7") ;original VA
- S TIUEDFLT="T-6M" ;default is 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 initialize of IHS variables
- 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=".03" ;sort by visit 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 ;search 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 TIUCLASS'=3,$$DOCCLASS^TIULC1(TIUT)'=TIUCLASS Q ;added to screen out by doc class
- . . . . ;I TIUTP=81,(+TYPES>1),($P(TYPES(TIUT),U,4)="NOT PICKED"),'+$$DADINTYP(TIUIFN,.TYPES) Q ;original VA-addendums okay
- . . . . 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
- Q $$GET1^DIQ(9000010,+$$GET1^DIQ(8925,DA,.03),.01,"I")_U_$$GET1^DIQ(8925,DA,DR,"I")_U_$$GET1^DIQ(8925,DA,1201,"I") ;use IHS fields
- 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 document 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 ;IHS added
- Q
- URGENCY(TIUDA) ; What is the urgency of the current document
- 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)
- BTIURPT4 ; IHS/ITSC/LJF - Review documents by Reference Date ;
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;;NOV 04, 2004
- +2 ;Copy of ^TIURPTTL - IHS Browse document texts by visit 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 to search 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 ;S SCREEN=1,SCREEN(1)="APT^"_DFN ;original VA
- +4 ;use IHS visit xref
- SET SCREEN=1
- SET SCREEN(1)="AIHS1^"_DFN
- +5 ;D CHECKADD(.TIUTYP) ;original VA - don't check addendums
- ERLY ;S TIUEDFLT=$S(TIUCLASS=3:"T-2",TIUCLASS=244:"T-30",1:"T-7") ;original VA
- +1 ;default is 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 initialize of IHS variables
- 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 visit date
- SET TIUSFLD=".03"
- +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 ;search 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 ;added to screen out by doc class
- IF TIUCLASS'=3
- IF $$DOCCLASS^TIULC1(TIUT)'=TIUCLASS
- QUIT
- +19 ;I TIUTP=81,(+TYPES>1),($P(TYPES(TIUT),U,4)="NOT PICKED"),'+$$DADINTYP(TIUIFN,.TYPES) Q ;original VA-addendums okay
- +20 SET TIUQ=$$RESOLVE(TIUIFN,TIUSFLD)
- +21 SET ^TMP("TIUI",$JOB,TIUQ,TIUJ,TIUIFN)=""
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +22 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 ;use IHS fields
- QUIT $$GET1^DIQ(9000010,+$$GET1^DIQ(8925,DA,.03),.01,"I")_U_$$GET1^DIQ(8925,DA,DR,"I")_U_$$GET1^DIQ(8925,DA,1201,"I")
- +2 NEW DIC,DIQ,X,Y,TIUY
- SET DIC=8925
- SET DIQ="TIUY"
- SET DIQ(0)="IE"
- +3 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
- +4 DO EN^DIQ1
- +5 IF $DATA(TIUY)
- Begin DoDot:1
- +6 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
- +7 IF TIUY']""
- SET TIUY="ZZZZEMPTY"
- +8 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 document 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 ;IHS added
- KILL TIUZCNT,TIUZLN
- +4 QUIT
- URGENCY(TIUDA) ; What is the urgency of the current document
- +1 NEW TIUY,TIUD0,TIUDSTAT,TIUDURG
- +2 SET TIUD0=$GET(^TIU(8925,+TIUDA,0))
- SET TIUDSTAT=$PIECE(TIUD0,U,5)
- +3 SET TIUDURG=$PIECE(TIUD0,U,9)
- +4 SET TIUY=$SELECT(TIUDSTAT<7:$SELECT(TIUDURG="P":1,1:2),1:3)
- +5 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)
