TIUPUTCN ; SLC/JER - Uploading Consult Results ;4/18/03
;;1.0;TEXT INTEGRATION UTILITIES;**4,100,120,131,113**;Jun 20, 1997
; External References in TIUPUTCN:
; DBIA 3472 $$CPPAT^GMRCCP
LOOKUP ; Lookup Method for Consults document definition
; Required: TIUSSN, TIUVDT,TIUCNNBR
N DA,DFN,TIU,TIUDAD,TIUDPRM,TIUEDIT,TIUEDT,TIULDT,TIUXCRP,TIUTYPE,TIUNEW
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
I $G(TIUCNNBR)']"" 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
; Confirm that patient from transcribed Consult Request Number matches
;pt from transcribed SSN:
I '$$CPPAT^GMRCCP(TIUCNNBR,DFN) S Y=-1 G LOOKUPX ; TIU*1*131
D DOCPRM^TIULC1(TIUTYPE,.TIUDPRM)
S TIUTYP(1)=1_U_TIUTYPE_U_$$PNAME^TIULC1(TIUTYPE)
S Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
I +Y'>0 G LOOKUPX
; If record is not new, is not yet released, then delete
;existing text to prepare for replacement:
I +$G(TIUNEW)'>0 D
. S TIUEDIT=$$CANEDIT(+Y)
. I +TIUEDIT>0,$D(^TIU(8925,+Y,"TEXT")) D DELTEXT(+Y)
. ; If already released, then make an addendum:
. I +TIUEDIT'>0 S TIUDAD=+Y,Y=$$MAKEADD
I +Y'>0 Q
; Stuff transcribed look-up data, etc.:
D STUFREC(Y,+$G(TIUDAD))
I +$G(TIUDAD) D SENDADD^TIUALRT(+Y)
; Prevent STUFREC^TIUPUTC from overwriting unneeded fields with
;possibly erroneous transcribed data:
K TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
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
MAKEADD() ; Create an addendum record
N DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUFPRIV S TIUFPRIV=1
; Get 8925.1 IEN for title "ADDENDUM"; DON'T require it to be consult
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 look-up header data, etc.
; Stuff look-up data, data derived from look-up data, and all other
;necessary, known, nontranscribed data: pt, visit, visit-derived data,
;entry dt/tm, ref date, capture meth, status (unreleased).
; (Remaining transcribed header data is generically stuffed later
;in MAIN^TIUPUTC, along with transcribed report text.)
N FDA,FDARR,IENS,FLAGS,TIUMSG
S IENS=""""_DA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
I +$G(PARENT)'>0 D
. S @FDARR@(.02)=$G(DFN),@FDARR@(.03)=$P($G(TIU("VISIT")),U)
. S @FDARR@(.05)=3
. 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@(1211)=$P($G(TIU("VLOC")),U)
. S @FDARR@(1404)=$P($G(TIU("SVC")),U)
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),@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
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"
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^TIUCNSLT
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 CONSULTS
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 " now 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPUTCN 6351 printed Dec 13, 2024@02:44:36 Page 2
TIUPUTCN ; SLC/JER - Uploading Consult Results ;4/18/03
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**4,100,120,131,113**;Jun 20, 1997
+2 ; External References in TIUPUTCN:
+3 ; DBIA 3472 $$CPPAT^GMRCCP
LOOKUP ; Lookup Method for Consults document definition
+1 ; Required: TIUSSN, TIUVDT,TIUCNNBR
+2 NEW DA,DFN,TIU,TIUDAD,TIUDPRM,TIUEDIT,TIUEDT,TIULDT,TIUXCRP,TIUTYPE,TIUNEW
+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 IF $GET(TIUCNNBR)']""
SET Y=-1
GOTO LOOKUPX
+7 SET TIULOC=+$$ILOC(TIULOC)
+8 IF '$DATA(^SC(+$GET(TIULOC),0))
SET Y=-1
GOTO LOOKUPX
+9 SET TIUINST=+$$DIVISION^TIULC1(TIULOC)
+10 SET TIUEDT=$$IDATE^TIULC(TIUVDT)
SET TIULDT=$$FMADD^XLFDT(TIUEDT,1)
+11 IF +TIUEDT'>0
SET Y=-1
QUIT
+12 SET TIUTYPE=$$WHATITLE(TIUTITLE)
+13 IF +TIUTYPE'>0
SET Y=-1
QUIT
+14 IF $PIECE($GET(^SC(+TIULOC,0)),U,3)="W"
Begin DoDot:1
+15 DO MAIN^TIUMOVE(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,1,"LAST",0,TIULOC)
End DoDot:1
IF 1
+16 IF '$TEST
DO MAIN^TIUVSIT(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,"LAST",0,TIULOC)
+17 IF $SELECT($DATA(TIU)'>9:1,+$GET(DFN)'>0:1,1:0)
SET Y=-1
GOTO LOOKUPX
+18 IF $PIECE(+$GET(TIU("EDT")),".")'=$PIECE($$IDATE^TIULC(TIUVDT),".")
SET Y=-1
GOTO LOOKUPX
+19 ; Confirm that patient from transcribed Consult Request Number matches
+20 ;pt from transcribed SSN:
+21 ; TIU*1*131
IF '$$CPPAT^GMRCCP(TIUCNNBR,DFN)
SET Y=-1
GOTO LOOKUPX
+22 DO DOCPRM^TIULC1(TIUTYPE,.TIUDPRM)
+23 SET TIUTYP(1)=1_U_TIUTYPE_U_$$PNAME^TIULC1(TIUTYPE)
+24 SET Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
+25 IF +Y'>0
GOTO LOOKUPX
+26 ; If record is not new, is not yet released, then delete
+27 ;existing text to prepare for replacement:
+28 IF +$GET(TIUNEW)'>0
Begin DoDot:1
+29 SET TIUEDIT=$$CANEDIT(+Y)
+30 IF +TIUEDIT>0
IF $DATA(^TIU(8925,+Y,"TEXT"))
DO DELTEXT(+Y)
+31 ; If already released, then make an addendum:
+32 IF +TIUEDIT'>0
SET TIUDAD=+Y
SET Y=$$MAKEADD
End DoDot:1
+33 IF +Y'>0
QUIT
+34 ; Stuff transcribed look-up data, etc.:
+35 DO STUFREC(Y,+$GET(TIUDAD))
+36 IF +$GET(TIUDAD)
DO SENDADD^TIUALRT(+Y)
+37 ; Prevent STUFREC^TIUPUTC from overwriting unneeded fields with
+38 ;possibly erroneous transcribed data:
+39 KILL TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
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)
MAKEADD() ; Create an addendum record
+1 NEW DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUFPRIV
SET TIUFPRIV=1
+2 ; Get 8925.1 IEN for title "ADDENDUM"; DON'T require it to be consult
+3 SET TIUATYP=+$$WHATITLE^TIUPUTU("ADDENDUM")
+4 SET (DIC,DLAYGO)=8925
SET DIC(0)="L"
SET X=""""_"`"_TIUATYP_""""
+5 DO ^DIC
+6 SET DA=+Y
+7 IF +DA>0
SET DIE=DIC
SET DR=".04////"_$$DOCCLASS^TIULC1(TIUATYP)
DO ^DIE
+8 KILL TIUHDR(.01)
+9 QUIT +DA
STUFREC(DA,PARENT) ; Stuff look-up header data, etc.
+1 ; Stuff look-up data, data derived from look-up data, and all other
+2 ;necessary, known, nontranscribed data: pt, visit, visit-derived data,
+3 ;entry dt/tm, ref date, capture meth, status (unreleased).
+4 ; (Remaining transcribed header data is generically stuffed later
+5 ;in MAIN^TIUPUTC, along with transcribed report text.)
+6 NEW FDA,FDARR,IENS,FLAGS,TIUMSG
+7 SET IENS=""""_DA_","""
SET FDARR="FDA(8925,"_IENS_")"
SET FLAGS="K"
+8 IF +$GET(PARENT)'>0
Begin DoDot:1
+9 SET @FDARR@(.02)=$GET(DFN)
SET @FDARR@(.03)=$PIECE($GET(TIU("VISIT")),U)
+10 SET @FDARR@(.05)=3
+11 SET @FDARR@(.07)=$PIECE($GET(TIU("EDT")),U)
+12 SET @FDARR@(.08)=$PIECE($GET(TIU("LDT")),U)
+13 SET @FDARR@(1201)=$$NOW^TIULC
+14 SET @FDARR@(1205)=$SELECT(+$PIECE($GET(TIU("LOC")),U):$PIECE($GET(TIU("LOC")),U),1:$PIECE($GET(TIU("VLOC")),U))
+15 ;S @FDARR@(1211)=$P($G(TIU("VLOC")),U)
+16 SET @FDARR@(1404)=$PIECE($GET(TIU("SVC")),U)
End DoDot:1
+17 IF +$GET(PARENT)>0
Begin DoDot:1
+18 SET @FDARR@(.02)=+$PIECE($GET(^TIU(8925,+PARENT,0)),U,2)
+19 SET @FDARR@(.03)=+$PIECE($GET(^TIU(8925,+PARENT,0)),U,3)
SET @FDARR@(.05)=3
+20 SET @FDARR@(.06)=PARENT
+21 SET @FDARR@(.07)=$PIECE($GET(^TIU(8925,+PARENT,0)),U,7)
+22 SET @FDARR@(.08)=$PIECE($GET(^TIU(8925,+PARENT,0)),U,8)
+23 SET @FDARR@(1205)=$PIECE($GET(^TIU(8925,+PARENT,12)),U,5)
+24 SET @FDARR@(1404)=$PIECE($GET(^TIU(8925,+PARENT,14)),U,4)
+25 SET @FDARR@(1201)=$$NOW^TIULC
End DoDot:1
+26 SET @FDARR@(1205)=$PIECE($GET(TIU("LOC")),U)
+27 SET @FDARR@(1212)=$PIECE($GET(TIU("INST")),U)
+28 SET @FDARR@(1301)=$SELECT($GET(TIUDDT)]"":$$IDATE^TIULC($GET(TIUDDT)),1:"")
+29 IF @FDARR@(1301)'>0
SET @FDARR@(1301)=$GET(@FDARR@(.07))
+30 SET @FDARR@(1303)="U"
+31 ; File record
DO FILE^DIE(FLAGS,"FDA","TIUMSG")
+32 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^TIUCNSLT
+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 CONSULTS
+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 " now 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
