TIUPUTCP ; SLC/JER,RMO - CP Look-up Method ;4/18/03
;;1.0;TEXT INTEGRATION UTILITIES;**109,113**;Jun 20, 1997
; This routine is a modified version of TIUPUTCN
LOOKUP ; Look-up code used by router/filer
; Required: TIUSSN, TIUVDT, TIUCNNBR
N DA,DFN,TIU,TIUDAD,TIUDPRM,TIUEDIT,TIUEDT,TIULDT,TIUXCRP,TIUTYPE,TIUNEW,TIUDNB
I $S('$D(TIUSSN):1,'$D(TIUVDT):1,$G(TIUSSN)?4N:1,$G(TIUSSN)']"":1,1:0) S Y=-1 G LOOKUPX
I TIUSSN?3N1P2N1P4N.E S TIUSSN=$TR(TIUSSN,"-/","")
I TIUSSN["?" S Y=-1 G LOOKUPX
S TIULOC=+$$ILOC(TIULOC)
I '$D(^SC(+$G(TIULOC),0)) S Y=-1 G LOOKUPX
S TIUINST=+$$DIVISION^TIULC1(TIULOC)
S TIUEDT=$$IDATE^TIULC(TIUVDT),TIULDT=$$FMADD^XLFDT(TIUEDT,1)
I +TIUEDT'>0 S Y=-1 Q
S TIUTYPE=$$WHATITLE(TIUTITLE)
I +TIUTYPE'>0 S Y=-1 Q
I $P($G(^SC(+TIULOC,0)),U,3)="W" D I 1
. D MAIN^TIUMOVE(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,1,"LAST",0,TIULOC)
E D MAIN^TIUVSIT(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,"LAST",0,TIULOC)
I $S($D(TIU)'>9:1,+$G(DFN)'>0:1,1:0) S Y=-1 G LOOKUPX
I $P(+$G(TIU("EDT")),".")'=$P($$IDATE^TIULC(TIUVDT),".") S Y=-1 G LOOKUPX
D DOCPRM^TIULC1(TIUTYPE,.TIUDPRM)
;
;Check consult associated with document
I '$$CHKCN($G(TIUCNNBR),DFN,$G(TIUPLDA),.TIUDNB) S Y=-1 G LOOKUPX
;
;Check status of consult as it relates to CP
I '$$CHKCP($G(TIUCNNBR),$G(TIUPLDA),.TIUDNB) S Y=-1 G LOOKUPX
S TIUTYP(1)=1_U_TIUTYPE_U_$$PNAME^TIULC1(TIUTYPE)
;
;If TIU document IEN is defined use it, otherwise call TIUEDI3
I $G(TIUPLDA)>0 D
. S Y=TIUPLDA
ELSE D
. S Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
I +Y'>0 G LOOKUPX
; If record is not new, has text and can be edited, then replace
; existing text
I +$G(TIUNEW)'>0 D
. S TIUEDIT=$$CANEDIT(+Y)
. I +TIUEDIT>0,$D(^TIU(8925,+Y,"TEXT")) D DELTEXT(+Y)
. I +TIUEDIT'>0 S TIUDAD=+Y,Y=$$MAKEADD
I +Y'>0 Q
D STUFREC(Y,+$G(TIUDAD))
I +$G(TIUDAD) D SENDADD^TIUALRT(+Y)
;Kill elements of TIUHDR so data is not filed twice
K TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
K TIUHDR(.001),TIUHDR(70201),TIUHDR(70202)
LOOKUPX Q
ILOC(LOCATION) ; Get pointer to file 44
N DIC,X,Y
S DIC=44,DIC(0)="M",X=LOCATION D ^DIC
Q Y
CANEDIT(DA) ; Check if document is not released yet
Q $S(+$P($G(^TIU(8925,+DA,0)),U,5)<4:1,1:0) ;TIU*1*131
;
CHKCN(TIUCDA,DFN,TIUDA,TIUDNB) ;Check if Consult is associated with correct patient
;and document
; Input -- TIUCDA Request/Consult file (#123) IEN
; DFN Patient file (#2) IEN
; TIUDA TIU Document file (#8925) IEN (Optional)
; Output -- 1=Successful and 0=Failure
; TIUDNB Dialogue Number for Error Message (Optional)
N OKF
;
I $G(TIUCDA)']"" S TIUDNB=89250009 G CHKCNQ
;
;Check if the patient is associated with the consult
I '$$CPPAT^GMRCCP(TIUCDA,DFN) S TIUDNB=89250006 G CHKCNQ
;
;Check 0th node and consult if document IEN is defined
I $G(TIUDA)>0 D G CHKCNQ:$G(TIUDNB)
. ;Check if 0th node of document is defined
. I $G(^TIU(8925,TIUDA,0))="" S TIUDNB=89250007 Q
. ;Check if consult is associated with the document
. I +$P($G(^TIU(8925,TIUDA,14)),U,5)'=TIUCDA S TIUDNB=89250008 Q
;
;Set success flag
S OKF=1
;
CHKCNQ Q +$G(OKF)
;
CHKCP(TIUCDA,TIUDA,TIUDNB) ;Check status of Consult as it relates to CP
; Input -- TIUCDA Request/Consult file (#123) IEN
; TIUDA TIU Document file (#8925) IEN (Optional)
; Output -- 1=Successful and 0=Failure
; TIUDNB Dialogue Number for Error Message (Optional)
N OKF,TIUCPACT
S TIUCPACT=$$CPACTM^GMRCCP(TIUCDA)
I 'TIUCPACT S TIUDNB=89250010 G CHKCPQ
I TIUCPACT=2 S TIUDNB=89250011 G CHKCPQ
I TIUCPACT=3,$G(TIUDA)'>0 S TIUDNB=89250012 G CHKCPQ
;
;Set success flag
S OKF=1
;
CHKCPQ Q +$G(OKF)
;
MAKEADD() ; Create an addendum record
N DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUFPRIV S TIUFPRIV=1
S TIUATYP=+$$WHATITLE^TIUPUTU("ADDENDUM")
S (DIC,DLAYGO)=8925,DIC(0)="L",X=""""_"`"_TIUATYP_""""
D ^DIC
S DA=+Y
I +DA>0 S DIE=DIC,DR=".04////"_$$DOCCLASS^TIULC1(TIUATYP) D ^DIE
K TIUHDR(.01)
Q +DA
STUFREC(DA,PARENT) ; Stuff fixed field data
N FDA,FDARR,IENS,FLAGS,TIUMSG,TIUPSCI,TIUDTPI
S IENS=""""_DA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
I +$G(PARENT)'>0 D
. I '$G(TIUPLDA) D
. . S @FDARR@(.02)=$G(DFN),@FDARR@(.03)=$P($G(TIU("VISIT")),U)
. . S @FDARR@(.07)=$P($G(TIU("EDT")),U)
. . S @FDARR@(.08)=$P($G(TIU("LDT")),U)
. . S @FDARR@(1201)=$$NOW^TIULC
. . S @FDARR@(1205)=$S(+$P($G(TIU("LOC")),U):$P($G(TIU("LOC")),U),1:$P($G(TIU("VLOC")),U))
. . S @FDARR@(1404)=$P($G(TIU("SVC")),U)
. I '$G(TIUPLDA)!('$P($G(^TIU(8925,+$G(TIUPLDA),13)),U,4)) S @FDARR@(.05)=3
I +$G(PARENT)>0 D
. S @FDARR@(.02)=+$P($G(^TIU(8925,+PARENT,0)),U,2)
. S @FDARR@(.03)=$P($G(^TIU(8925,+PARENT,0)),U,3)
. S @FDARR@(.05)=3
. S @FDARR@(.06)=PARENT
. S @FDARR@(.07)=$P($G(^TIU(8925,+PARENT,0)),U,7)
. S @FDARR@(.08)=$P($G(^TIU(8925,+PARENT,0)),U,8)
. S @FDARR@(1205)=$P($G(^TIU(8925,+PARENT,12)),U,5)
. S @FDARR@(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4)
. S @FDARR@(1201)=$$NOW^TIULC
I '$G(TIUPLDA) S @FDARR@(1205)=$P($G(TIU("LOC")),U)
S @FDARR@(1212)=$P($G(TIU("INST")),U)
S @FDARR@(1301)=$S($G(TIUDDT)]"":$$IDATE^TIULC($G(TIUDDT)),1:"")
I @FDARR@(1301)'>0 S @FDARR@(1301)=$G(@FDARR@(.07))
S @FDARR@(1303)="U"
I $G(TIUPSC)]"" D VAL^DIE(8925,DA,70201,,TIUPSC,.TIUPSCI)
S @FDARR@(70201)=$S($G(TIUPSCI):TIUPSCI,1:"")
I '$G(TIUPLDA)!($P($G(^TIU(8925,+$G(TIUPLDA),702)),U,2))="" D
. I $G(TIUDTP)]"" D VAL^DIE(8925,DA,70202,,TIUDTP,.TIUDTPI)
. S @FDARR@(70202)=$S($G(TIUDTPI):TIUDTPI,1:"")
D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
Q
DELTEXT(DA) ; Delete existing text in preparation for replacement
N DIE,DR,X,Y
S DIE=8925,DR="2///@" D ^DIE
Q
WHATYPE(X) ; Identify document type
; Receives: X=Document Definition Name
; Returns: Y=Document Definition IFN
N DIC,Y,TIUFPRIV S TIUFPRIV=1
S DIC=8925.1,DIC(0)="M"
S DIC("S")="I +$O(^TIU(8925.1,+Y,""HEAD"",0))!+$O(^TIU(8295.1,+Y,""ITEM"",0))"
D ^DIC K DIC("S")
WHATYPX Q Y
WHATITLE(X) ; Identify document title
; Receives: X=Document Definition Name
; Returns: Y=Document Definition IFN
N DIC,Y,TIUFPRIV,SCREEN,TIUCLASS S TIUFPRIV=1
S DIC=8925.1,DIC(0)="M",TIUCLASS=+$$CLASS^TIUCP
S SCREEN="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"",+$$ISA^TIULX(+Y,"_TIUCLASS_"),+$$CANPICK^TIULP(+Y)"
S DIC("S")=SCREEN
D ^DIC K DIC("S")
WHATITX Q Y
FOLLOWUP(TIUDA) ; Post-filing code for CLINICAL PROCEDURES
N FDA,FDARR,IENS,FLAGS,TIUMSG,TIU,DFN
S IENS=""""_TIUDA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
S @FDARR@(1204)=$$WHOSIGNS^TIULC1(TIUDA)
I +$P($G(^TIU(8925,TIUDA,12)),U,9),'+$P($G(^(12)),U,8) D
. S @FDARR@(1208)=$$WHOCOSIG^TIULC1(TIUDA)
D FILE^DIE(FLAGS,"FDA","TIUMSG")
I +$P($G(^TIU(8925,+TIUDA,12)),U,8),(+$P($G(^TIU(8925,+TIUDA,12)),U,4)'=+$P($G(^(12)),U,8)) D
. S @FDARR@(1506)=1 D FILE^DIE(FLAGS,"FDA","TIUMSG")
D RELEASE^TIUT(TIUDA,1)
D AUDIT^TIUEDI1(TIUDA,0,$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")"))
I +$P($G(^TIU(8925,+TIUDA,14)),U,5) D
. N TIUCDA,DA S TIUCDA=+$P($G(^TIU(8925,+TIUDA,14)),U,5)
. W !,$$PNAME^TIULC1(+$G(^TIU(8925,+TIUDA,0)))," #: ",TIUDA
. W " Linked to Consult Request #: ",TIUCDA,".",!
. ; Post result in CT Pkg
. D GET^GMRCTIU(TIUCDA,TIUDA,"INCOMPLETE RPT")
I '$D(TIU("VSTR")) D
. N TIUD0,TIUD12,TIUVLOC,TIUHLOC,TIUEDT,TIULDT
. S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^(12))
. S DFN=+$P(TIUD0,U,2),TIUEDT=+$P(TIUD0,U,7)
. S TIULDT=$$FMADD^XLFDT(TIUEDT,1),TIUHLOC=+$P(TIUD12,U,5)
. S TIUVLOC=$S(+$P(TIUD12,U,11):+$P(TIUD12,U,11),1:+TIUHLOC)
. I $S(+DFN'>0:1,+TIUEDT'>0:1,+TIULDT'>0:1,+TIUVLOC'>0:1,1:0) Q
. D MAIN^TIUVSIT(.TIU,DFN,"",TIUEDT,TIULDT,"LAST",0,+TIUVLOC)
Q:'$D(TIU("VSTR"))
D QUE^TIUPXAP1 ; Get/file VISIT
Q
GETCP ; Help get Fields for CP Dictation/Error Resolution
N TIU,DFN,TIUY,TITLE,TIUBUF,TIUPLDA,TIUMVN,TIUVSTR
W ! S DFN=+$$PATIENT^TIULA G GETCPQ:+DFN'>0
S TIUBUF=$S(+$G(BUFDA):+$G(BUFDA),+$G(XQADATA):+$G(XQADATA),1:"")
;If there is a buffer entry with a TIU Document Number, ask for document
I $G(TIUBUF),$$CHKUPL(TIUBUF) D G GETCPQ:'$D(TIU)
. I $$ASKUPL(DFN,.TIUPLDA) D
. . ;If Patient Movement
. . I +$G(^TIU(8925,+TIUPLDA,14)) D
. . . S TIUMVN=+$G(^TIU(8925,+TIUPLDA,14))
. . ;Else set up Visit string
. . ELSE D
. . . S TIUVSTR=$P($G(^TIU(8925,+TIUPLDA,12)),U,11)_";"_$P($G(^TIU(8925,+TIUPLDA,0)),U,7)_";"_$P($G(^TIU(8925,+TIUPLDA,0)),U,13)
. . ;Populate demographic and Visit information
. . D PATVADPT^TIULV(.TIU,DFN,$G(TIUMVN),$G(TIUVSTR))
ELSE D G GETCPQ:'$D(TIU)
. ;If there is no stub ask for Visit
. D ENPN^TIUVSIT(.TIU,+DFN,1)
. I '$D(TIU) Q
. S TIUY=$$CHEKPN^TIUCHLP(.TIU)
D MAKE^TIUCPFIX(.SUCCESS,DFN,.TITLE,.TIU,$G(TIUBUF),$G(TIUPLDA))
I +SUCCESS D
. S TIUDONE=1
ELSE D
. W !!,"Please correct the buffered upload data.",!,$P(SUCCESS,U,2),!
. I $$READ^TIUU("FOA","Press RETURN to continue...") W ""
GETCPQ Q
;
CHKUPL(TIUBUF) ;Check if Buffer Entry has TIU Document Number
; Input -- TIUBUF TIU Upload Buffer file (#8925.2) IEN
; Output -- 1=Yes and 0=No
N TIUX,Y
D LOADTIUX^TIUCPFIX(.TIUX,TIUBUF)
I $G(TIUX(.001)) S Y=1
Q +$G(Y)
;
ASKUPL(DFN,TIUPLDA) ;Ask TIU Document Number for Error Resolution
; Input -- DFN Patient file (#2) IEN
; Output -- 1=Successful and 0=Failure
; TIUPLDA TIU Document file (#8925) IEN
N D,DD,DIC,DINUM,DLAYGO,D0,X,Y
S DIC="^TIU(8925,",DIC(0)="EUVX",D="C"
S X=DFN
S DIC("S")="I $P(^(0),U,5)=1,+$$ISA^TIULX(+$P(^(0),U),+$$CLASS^TIUCP)"
S DIC("W")="D ID^TIUPUTCP(+Y)"
D IX^DIC
I Y>0 S TIUPLDA=+Y
Q $S($G(TIUPLDA)="":0,1:1)
;
ID(TIUDA) ;Display TIU Document Information for Error Resolution
; Input -- TIUDA TIU Document file (#8925) IEN (Optional)
; Output -- None
W !?12,"Document #: ",TIUDA
W ?34,"Dated: ",$$DATE^TIULS(+$G(^TIU(8925,+TIUDA,13)),"MM/DD/CCYY@HR:MIN")
W ?60,"Consult #: ",+$P($G(^TIU(8925,+TIUDA,14)),U,5)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPUTCP 9992 printed Oct 16, 2024@18:45:11 Page 2
TIUPUTCP ; SLC/JER,RMO - CP Look-up Method ;4/18/03
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**109,113**;Jun 20, 1997
+2 ; This routine is a modified version of TIUPUTCN
LOOKUP ; Look-up code used by router/filer
+1 ; Required: TIUSSN, TIUVDT, TIUCNNBR
+2 NEW DA,DFN,TIU,TIUDAD,TIUDPRM,TIUEDIT,TIUEDT,TIULDT,TIUXCRP,TIUTYPE,TIUNEW,TIUDNB
+3 IF $SELECT('$DATA(TIUSSN):1,'$DATA(TIUVDT):1,$GET(TIUSSN)?4N:1,$GET(TIUSSN)']"":1,1:0)
SET Y=-1
GOTO LOOKUPX
+4 IF TIUSSN?3N1P2N1P4N.E
SET TIUSSN=$TRANSLATE(TIUSSN,"-/","")
+5 IF TIUSSN["?"
SET Y=-1
GOTO LOOKUPX
+6 SET TIULOC=+$$ILOC(TIULOC)
+7 IF '$DATA(^SC(+$GET(TIULOC),0))
SET Y=-1
GOTO LOOKUPX
+8 SET TIUINST=+$$DIVISION^TIULC1(TIULOC)
+9 SET TIUEDT=$$IDATE^TIULC(TIUVDT)
SET TIULDT=$$FMADD^XLFDT(TIUEDT,1)
+10 IF +TIUEDT'>0
SET Y=-1
QUIT
+11 SET TIUTYPE=$$WHATITLE(TIUTITLE)
+12 IF +TIUTYPE'>0
SET Y=-1
QUIT
+13 IF $PIECE($GET(^SC(+TIULOC,0)),U,3)="W"
Begin DoDot:1
+14 DO MAIN^TIUMOVE(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,1,"LAST",0,TIULOC)
End DoDot:1
IF 1
+15 IF '$TEST
DO MAIN^TIUVSIT(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,"LAST",0,TIULOC)
+16 IF $SELECT($DATA(TIU)'>9:1,+$GET(DFN)'>0:1,1:0)
SET Y=-1
GOTO LOOKUPX
+17 IF $PIECE(+$GET(TIU("EDT")),".")'=$PIECE($$IDATE^TIULC(TIUVDT),".")
SET Y=-1
GOTO LOOKUPX
+18 DO DOCPRM^TIULC1(TIUTYPE,.TIUDPRM)
+19 ;
+20 ;Check consult associated with document
+21 IF '$$CHKCN($GET(TIUCNNBR),DFN,$GET(TIUPLDA),.TIUDNB)
SET Y=-1
GOTO LOOKUPX
+22 ;
+23 ;Check status of consult as it relates to CP
+24 IF '$$CHKCP($GET(TIUCNNBR),$GET(TIUPLDA),.TIUDNB)
SET Y=-1
GOTO LOOKUPX
+25 SET TIUTYP(1)=1_U_TIUTYPE_U_$$PNAME^TIULC1(TIUTYPE)
+26 ;
+27 ;If TIU document IEN is defined use it, otherwise call TIUEDI3
+28 IF $GET(TIUPLDA)>0
Begin DoDot:1
+29 SET Y=TIUPLDA
End DoDot:1
+30 IF '$TEST
Begin DoDot:1
+31 SET Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
End DoDot:1
+32 IF +Y'>0
GOTO LOOKUPX
+33 ; If record is not new, has text and can be edited, then replace
+34 ; existing text
+35 IF +$GET(TIUNEW)'>0
Begin DoDot:1
+36 SET TIUEDIT=$$CANEDIT(+Y)
+37 IF +TIUEDIT>0
IF $DATA(^TIU(8925,+Y,"TEXT"))
DO DELTEXT(+Y)
+38 IF +TIUEDIT'>0
SET TIUDAD=+Y
SET Y=$$MAKEADD
End DoDot:1
+39 IF +Y'>0
QUIT
+40 DO STUFREC(Y,+$GET(TIUDAD))
+41 IF +$GET(TIUDAD)
DO SENDADD^TIUALRT(+Y)
+42 ;Kill elements of TIUHDR so data is not filed twice
+43 KILL TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
+44 KILL TIUHDR(.001),TIUHDR(70201),TIUHDR(70202)
LOOKUPX QUIT
ILOC(LOCATION) ; Get pointer to file 44
+1 NEW DIC,X,Y
+2 SET DIC=44
SET DIC(0)="M"
SET X=LOCATION
DO ^DIC
+3 QUIT Y
CANEDIT(DA) ; Check if document is not released yet
+1 ;TIU*1*131
QUIT $SELECT(+$PIECE($GET(^TIU(8925,+DA,0)),U,5)<4:1,1:0)
+2 ;
CHKCN(TIUCDA,DFN,TIUDA,TIUDNB) ;Check if Consult is associated with correct patient
+1 ;and document
+2 ; Input -- TIUCDA Request/Consult file (#123) IEN
+3 ; DFN Patient file (#2) IEN
+4 ; TIUDA TIU Document file (#8925) IEN (Optional)
+5 ; Output -- 1=Successful and 0=Failure
+6 ; TIUDNB Dialogue Number for Error Message (Optional)
+7 NEW OKF
+8 ;
+9 IF $GET(TIUCDA)']""
SET TIUDNB=89250009
GOTO CHKCNQ
+10 ;
+11 ;Check if the patient is associated with the consult
+12 IF '$$CPPAT^GMRCCP(TIUCDA,DFN)
SET TIUDNB=89250006
GOTO CHKCNQ
+13 ;
+14 ;Check 0th node and consult if document IEN is defined
+15 IF $GET(TIUDA)>0
Begin DoDot:1
+16 ;Check if 0th node of document is defined
+17 IF $GET(^TIU(8925,TIUDA,0))=""
SET TIUDNB=89250007
QUIT
+18 ;Check if consult is associated with the document
+19 IF +$PIECE($GET(^TIU(8925,TIUDA,14)),U,5)'=TIUCDA
SET TIUDNB=89250008
QUIT
End DoDot:1
if $GET(TIUDNB)
GOTO CHKCNQ
+20 ;
+21 ;Set success flag
+22 SET OKF=1
+23 ;
CHKCNQ QUIT +$GET(OKF)
+1 ;
CHKCP(TIUCDA,TIUDA,TIUDNB) ;Check status of Consult as it relates to CP
+1 ; Input -- TIUCDA Request/Consult file (#123) IEN
+2 ; TIUDA TIU Document file (#8925) IEN (Optional)
+3 ; Output -- 1=Successful and 0=Failure
+4 ; TIUDNB Dialogue Number for Error Message (Optional)
+5 NEW OKF,TIUCPACT
+6 SET TIUCPACT=$$CPACTM^GMRCCP(TIUCDA)
+7 IF 'TIUCPACT
SET TIUDNB=89250010
GOTO CHKCPQ
+8 IF TIUCPACT=2
SET TIUDNB=89250011
GOTO CHKCPQ
+9 IF TIUCPACT=3
IF $GET(TIUDA)'>0
SET TIUDNB=89250012
GOTO CHKCPQ
+10 ;
+11 ;Set success flag
+12 SET OKF=1
+13 ;
CHKCPQ QUIT +$GET(OKF)
+1 ;
MAKEADD() ; Create an addendum record
+1 NEW DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUFPRIV
SET TIUFPRIV=1
+2 SET TIUATYP=+$$WHATITLE^TIUPUTU("ADDENDUM")
+3 SET (DIC,DLAYGO)=8925
SET DIC(0)="L"
SET X=""""_"`"_TIUATYP_""""
+4 DO ^DIC
+5 SET DA=+Y
+6 IF +DA>0
SET DIE=DIC
SET DR=".04////"_$$DOCCLASS^TIULC1(TIUATYP)
DO ^DIE
+7 KILL TIUHDR(.01)
+8 QUIT +DA
STUFREC(DA,PARENT) ; Stuff fixed field data
+1 NEW FDA,FDARR,IENS,FLAGS,TIUMSG,TIUPSCI,TIUDTPI
+2 SET IENS=""""_DA_","""
SET FDARR="FDA(8925,"_IENS_")"
SET FLAGS="K"
+3 IF +$GET(PARENT)'>0
Begin DoDot:1
+4 IF '$GET(TIUPLDA)
Begin DoDot:2
+5 SET @FDARR@(.02)=$GET(DFN)
SET @FDARR@(.03)=$PIECE($GET(TIU("VISIT")),U)
+6 SET @FDARR@(.07)=$PIECE($GET(TIU("EDT")),U)
+7 SET @FDARR@(.08)=$PIECE($GET(TIU("LDT")),U)
+8 SET @FDARR@(1201)=$$NOW^TIULC
+9 SET @FDARR@(1205)=$SELECT(+$PIECE($GET(TIU("LOC")),U):$PIECE($GET(TIU("LOC")),U),1:$PIECE($GET(TIU("VLOC")),U))
+10 SET @FDARR@(1404)=$PIECE($GET(TIU("SVC")),U)
End DoDot:2
+11 IF '$GET(TIUPLDA)!('$PIECE($GET(^TIU(8925,+$GET(TIUPLDA),13)),U,4))
SET @FDARR@(.05)=3
End DoDot:1
+12 IF +$GET(PARENT)>0
Begin DoDot:1
+13 SET @FDARR@(.02)=+$PIECE($GET(^TIU(8925,+PARENT,0)),U,2)
+14 SET @FDARR@(.03)=$PIECE($GET(^TIU(8925,+PARENT,0)),U,3)
+15 SET @FDARR@(.05)=3
+16 SET @FDARR@(.06)=PARENT
+17 SET @FDARR@(.07)=$PIECE($GET(^TIU(8925,+PARENT,0)),U,7)
+18 SET @FDARR@(.08)=$PIECE($GET(^TIU(8925,+PARENT,0)),U,8)
+19 SET @FDARR@(1205)=$PIECE($GET(^TIU(8925,+PARENT,12)),U,5)
+20 SET @FDARR@(1404)=$PIECE($GET(^TIU(8925,+PARENT,14)),U,4)
+21 SET @FDARR@(1201)=$$NOW^TIULC
End DoDot:1
+22 IF '$GET(TIUPLDA)
SET @FDARR@(1205)=$PIECE($GET(TIU("LOC")),U)
+23 SET @FDARR@(1212)=$PIECE($GET(TIU("INST")),U)
+24 SET @FDARR@(1301)=$SELECT($GET(TIUDDT)]"":$$IDATE^TIULC($GET(TIUDDT)),1:"")
+25 IF @FDARR@(1301)'>0
SET @FDARR@(1301)=$GET(@FDARR@(.07))
+26 SET @FDARR@(1303)="U"
+27 IF $GET(TIUPSC)]""
DO VAL^DIE(8925,DA,70201,,TIUPSC,.TIUPSCI)
+28 SET @FDARR@(70201)=$SELECT($GET(TIUPSCI):TIUPSCI,1:"")
+29 IF '$GET(TIUPLDA)!($PIECE($GET(^TIU(8925,+$GET(TIUPLDA),702)),U,2))=""
Begin DoDot:1
+30 IF $GET(TIUDTP)]""
DO VAL^DIE(8925,DA,70202,,TIUDTP,.TIUDTPI)
+31 SET @FDARR@(70202)=$SELECT($GET(TIUDTPI):TIUDTPI,1:"")
End DoDot:1
+32 ; File record
DO FILE^DIE(FLAGS,"FDA","TIUMSG")
+33 QUIT
DELTEXT(DA) ; Delete existing text in preparation for replacement
+1 NEW DIE,DR,X,Y
+2 SET DIE=8925
SET DR="2///@"
DO ^DIE
+3 QUIT
WHATYPE(X) ; Identify document type
+1 ; Receives: X=Document Definition Name
+2 ; Returns: Y=Document Definition IFN
+3 NEW DIC,Y,TIUFPRIV
SET TIUFPRIV=1
+4 SET DIC=8925.1
SET DIC(0)="M"
+5 SET DIC("S")="I +$O(^TIU(8925.1,+Y,""HEAD"",0))!+$O(^TIU(8295.1,+Y,""ITEM"",0))"
+6 DO ^DIC
KILL DIC("S")
WHATYPX QUIT Y
WHATITLE(X) ; Identify document title
+1 ; Receives: X=Document Definition Name
+2 ; Returns: Y=Document Definition IFN
+3 NEW DIC,Y,TIUFPRIV,SCREEN,TIUCLASS
SET TIUFPRIV=1
+4 SET DIC=8925.1
SET DIC(0)="M"
SET TIUCLASS=+$$CLASS^TIUCP
+5 SET SCREEN="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"",+$$ISA^TIULX(+Y,"_TIUCLASS_"),+$$CANPICK^TIULP(+Y)"
+6 SET DIC("S")=SCREEN
+7 DO ^DIC
KILL DIC("S")
WHATITX QUIT Y
FOLLOWUP(TIUDA) ; Post-filing code for CLINICAL PROCEDURES
+1 NEW FDA,FDARR,IENS,FLAGS,TIUMSG,TIU,DFN
+2 SET IENS=""""_TIUDA_","""
SET FDARR="FDA(8925,"_IENS_")"
SET FLAGS="K"
+3 SET @FDARR@(1204)=$$WHOSIGNS^TIULC1(TIUDA)
+4 IF +$PIECE($GET(^TIU(8925,TIUDA,12)),U,9)
IF '+$PIECE($GET(^(12)),U,8)
Begin DoDot:1
+5 SET @FDARR@(1208)=$$WHOCOSIG^TIULC1(TIUDA)
End DoDot:1
+6 DO FILE^DIE(FLAGS,"FDA","TIUMSG")
+7 IF +$PIECE($GET(^TIU(8925,+TIUDA,12)),U,8)
IF (+$PIECE($GET(^TIU(8925,+TIUDA,12)),U,4)'=+$PIECE($GET(^(12)),U,8))
Begin DoDot:1
+8 SET @FDARR@(1506)=1
DO FILE^DIE(FLAGS,"FDA","TIUMSG")
End DoDot:1
+9 DO RELEASE^TIUT(TIUDA,1)
+10 DO AUDIT^TIUEDI1(TIUDA,0,$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")"))
+11 IF +$PIECE($GET(^TIU(8925,+TIUDA,14)),U,5)
Begin DoDot:1
+12 NEW TIUCDA,DA
SET TIUCDA=+$PIECE($GET(^TIU(8925,+TIUDA,14)),U,5)
+13 WRITE !,$$PNAME^TIULC1(+$GET(^TIU(8925,+TIUDA,0)))," #: ",TIUDA
+14 WRITE " Linked to Consult Request #: ",TIUCDA,".",!
+15 ; Post result in CT Pkg
+16 DO GET^GMRCTIU(TIUCDA,TIUDA,"INCOMPLETE RPT")
End DoDot:1
+17 IF '$DATA(TIU("VSTR"))
Begin DoDot:1
+18 NEW TIUD0,TIUD12,TIUVLOC,TIUHLOC,TIUEDT,TIULDT
+19 SET TIUD0=$GET(^TIU(8925,+TIUDA,0))
SET TIUD12=$GET(^(12))
+20 SET DFN=+$PIECE(TIUD0,U,2)
SET TIUEDT=+$PIECE(TIUD0,U,7)
+21 SET TIULDT=$$FMADD^XLFDT(TIUEDT,1)
SET TIUHLOC=+$PIECE(TIUD12,U,5)
+22 SET TIUVLOC=$SELECT(+$PIECE(TIUD12,U,11):+$PIECE(TIUD12,U,11),1:+TIUHLOC)
+23 IF $SELECT(+DFN'>0:1,+TIUEDT'>0:1,+TIULDT'>0:1,+TIUVLOC'>0:1,1:0)
QUIT
+24 DO MAIN^TIUVSIT(.TIU,DFN,"",TIUEDT,TIULDT,"LAST",0,+TIUVLOC)
End DoDot:1
+25 if '$DATA(TIU("VSTR"))
QUIT
+26 ; Get/file VISIT
DO QUE^TIUPXAP1
+27 QUIT
GETCP ; Help get Fields for CP Dictation/Error Resolution
+1 NEW TIU,DFN,TIUY,TITLE,TIUBUF,TIUPLDA,TIUMVN,TIUVSTR
+2 WRITE !
SET DFN=+$$PATIENT^TIULA
if +DFN'>0
GOTO GETCPQ
+3 SET TIUBUF=$SELECT(+$GET(BUFDA):+$GET(BUFDA),+$GET(XQADATA):+$GET(XQADATA),1:"")
+4 ;If there is a buffer entry with a TIU Document Number, ask for document
+5 IF $GET(TIUBUF)
IF $$CHKUPL(TIUBUF)
Begin DoDot:1
+6 IF $$ASKUPL(DFN,.TIUPLDA)
Begin DoDot:2
+7 ;If Patient Movement
+8 IF +$GET(^TIU(8925,+TIUPLDA,14))
Begin DoDot:3
+9 SET TIUMVN=+$GET(^TIU(8925,+TIUPLDA,14))
End DoDot:3
+10 ;Else set up Visit string
+11 IF '$TEST
Begin DoDot:3
+12 SET TIUVSTR=$PIECE($GET(^TIU(8925,+TIUPLDA,12)),U,11)_";"_$PIECE($GET(^TIU(8925,+TIUPLDA,0)),U,7)_";"_$PIECE($GET(^TIU(8925,+TIUPLDA,0)),U,13)
End DoDot:3
+13 ;Populate demographic and Visit information
+14 DO PATVADPT^TIULV(.TIU,DFN,$GET(TIUMVN),$GET(TIUVSTR))
End DoDot:2
End DoDot:1
if '$DATA(TIU)
GOTO GETCPQ
+15 IF '$TEST
Begin DoDot:1
+16 ;If there is no stub ask for Visit
+17 DO ENPN^TIUVSIT(.TIU,+DFN,1)
+18 IF '$DATA(TIU)
QUIT
+19 SET TIUY=$$CHEKPN^TIUCHLP(.TIU)
End DoDot:1
if '$DATA(TIU)
GOTO GETCPQ
+20 DO MAKE^TIUCPFIX(.SUCCESS,DFN,.TITLE,.TIU,$GET(TIUBUF),$GET(TIUPLDA))
+21 IF +SUCCESS
Begin DoDot:1
+22 SET TIUDONE=1
End DoDot:1
+23 IF '$TEST
Begin DoDot:1
+24 WRITE !!,"Please correct the buffered upload data.",!,$PIECE(SUCCESS,U,2),!
+25 IF $$READ^TIUU("FOA","Press RETURN to continue...")
WRITE ""
End DoDot:1
GETCPQ QUIT
+1 ;
CHKUPL(TIUBUF) ;Check if Buffer Entry has TIU Document Number
+1 ; Input -- TIUBUF TIU Upload Buffer file (#8925.2) IEN
+2 ; Output -- 1=Yes and 0=No
+3 NEW TIUX,Y
+4 DO LOADTIUX^TIUCPFIX(.TIUX,TIUBUF)
+5 IF $GET(TIUX(.001))
SET Y=1
+6 QUIT +$GET(Y)
+7 ;
ASKUPL(DFN,TIUPLDA) ;Ask TIU Document Number for Error Resolution
+1 ; Input -- DFN Patient file (#2) IEN
+2 ; Output -- 1=Successful and 0=Failure
+3 ; TIUPLDA TIU Document file (#8925) IEN
+4 NEW D,DD,DIC,DINUM,DLAYGO,D0,X,Y
+5 SET DIC="^TIU(8925,"
SET DIC(0)="EUVX"
SET D="C"
+6 SET X=DFN
+7 SET DIC("S")="I $P(^(0),U,5)=1,+$$ISA^TIULX(+$P(^(0),U),+$$CLASS^TIUCP)"
+8 SET DIC("W")="D ID^TIUPUTCP(+Y)"
+9 DO IX^DIC
+10 IF Y>0
SET TIUPLDA=+Y
+11 QUIT $SELECT($GET(TIUPLDA)="":0,1:1)
+12 ;
ID(TIUDA) ;Display TIU Document Information for Error Resolution
+1 ; Input -- TIUDA TIU Document file (#8925) IEN (Optional)
+2 ; Output -- None
+3 WRITE !?12,"Document #: ",TIUDA
+4 WRITE ?34,"Dated: ",$$DATE^TIULS(+$GET(^TIU(8925,+TIUDA,13)),"MM/DD/CCYY@HR:MIN")
+5 WRITE ?60,"Consult #: ",+$PIECE($GET(^TIU(8925,+TIUDA,14)),U,5)
+6 QUIT
