TIUPUTC1 ; SLC/JER,AJB - Document filer Cont'd - captioned header ;Jul 09, 2020@12:06:28
;;1.0;TEXT INTEGRATION UTILITIES;**81,290,335**;Jun 20, 1997;Build 3
;
GETREC(HEADER,RECORD,TIUHDR) ; ---- Look-up/create record (if LAYGO allowed)
N DIC,DLAYGO,TIUD1,TIUD4,TIUKEY,X,Y,TIUDSFTR
I '$D(ZTQUEUED) W !!,">>> HEADER IDENTIFIED:",!,HEADER
S X=$$STRIP^TIULS($P(HEADER,":",2)),Y=$$WHATYPE^TIUPUTU(X)
I +Y'>0 D MAIN^TIUPEVNT(DA,1,3,X) D Q
. W:'$D(ZTQUEUED) !!,"INVALID DOCUMENT TYPE ",X,".",!
. S ^TMP("TIUPUTC",$J,"FAIL")=+$G(^TMP("TIUPUTC",$J,"FAIL"))+1
S TIUD1=$G(^TIU(8925.1,+Y,1)),TIUD4=$G(^TIU(8925.1,+Y,4))
S RECORD("TYPE")=+Y,RECORD("FILE")=$P(TIUD1,U)
S RECORD("BOILON")=$P(TIUD1,U,4)
I RECORD("FILE")']"" D MAIN^TIUPEVNT(DA,1,4,X) D Q
. W:'$D(ZTQUEUED) !!,"TARGET FILE NOT DEFINED FOR ",X,".",!
. S ^TMP("TIUPUTC",$J,"FAIL")=+$G(^TMP("TIUPUTC",$J,"FAIL"))+1
S RECORD("ROOT")=$G(^DIC(+RECORD("FILE"),0,"GL"))
I $P(TIUD1,U,3)']"" D MAIN^TIUPEVNT(DA,1,5,X) D Q
. W:'$D(ZTQUEUED) !!,"TEXT FIELD NOT DEFINED FOR ",X,".",!
. S ^TMP("TIUPUTC",$J,"FAIL")=+$G(^TMP("TIUPUTC",$J,"FAIL"))+1
I $P(TIUD1,U,3)]"" D
. ; ---- Get subscript of target file TEXT field
. S RECORD("TEXT")=$P($P(TIUD1,U,3),";",2)
. I RECORD("TEXT")]"",'+RECORD("TEXT") S RECORD("TEXT")=""""_RECORD("TEXT")_""""
F D Q:TIULINE[TIUBGN!(+TIUI'>0)
. N TIUNOD,TIUCAP,TIUVAR,TIUFIELD,TIUREQ S TIUREQ=0
. ; ---- Reset TIUI and Write out transferred header info:
. S TIUI=$O(^TIU(8925.2,+DA,"TEXT",TIUI)) Q:+TIUI'>0
. S TIULINE=$G(^TIU(8925.2,+DA,"TEXT",TIUI,0)) Q:TIULINE[TIUBGN
. I '$D(ZTQUEUED) W !,TIULINE
. ; ---- Check for field number, required missing fields:
. S TIUCAP=$P(TIULINE,":") Q:TIUCAP']""
. S TIUNOD=$O(^TIU(8925.1,+RECORD("TYPE"),"HEAD","B",TIUCAP,0)) Q:+TIUNOD'>0
. S TIUFIELD=$P(^TIU(8925.1,+RECORD("TYPE"),"HEAD",+TIUNOD,0),U,3)
. I TIUFIELD']"" W:'$D(ZTQUEUED) !,"Field Number NOT SPECIFIED for ",TIUCAP Q
. S TIUREQ=$P(^TIU(8925.1,+RECORD("TYPE"),"HEAD",+TIUNOD,0),U,7)
. S TIUHDR(TIUFIELD)=$$STRIP^TIULS($P(TIULINE,":",2,99))
. ;**TEST** - No future dictation dates for discharge summaries
. I TIUFIELD=1307,$$ISA^TIULX($G(TIUREC("TYPE")),$$CHKFILE^TIUADCL(8925.1,"DISCHARGE SUMMARY","I $P(^(0),U,4)=""CL""")),$G(TIUHDR("1307"))]"" S TIUDSFTR=$$DICTDT(TIUHDR("1307")) I TIUDSFTR D Q
. . S TIUHDR(TIUFIELD)="" I '$D(ZTQUEUED) W !,"**Future dictation dates are not allowed for this type of document**" S TIUFDT=1,^TMP("TIUPUTC",$J,"FAIL")=+$G(^TMP("TIUPUTC",$J,"FAIL"))+1 Q
. I +TIUREQ,TIUHDR(TIUFIELD)="" S TIUHDR(TIUFIELD)="** REQUIRED FIELD MISSING FROM UPLOAD **"
. ; ---- Get local lookup variables for document type:
. S TIUVAR=$P(^TIU(8925.1,+RECORD("TYPE"),"HEAD",+TIUNOD,0),U,4) Q:TIUVAR']""
. S TIUHDR(TIUVAR)=$$STRIP^TIULS($P(TIULINE,":",2,99))
Q:TIUFDT=1 I '$D(ZTQUEUED) W !,TIUBGN,!
S:+$P(TIUD1,U,2) DLAYGO=RECORD("FILE")
; Can't check if author Requires EC w/o Dict dt & AUTHOR so if not valid set FILING ERROR:
N TIUVALID S TIUVALID="YES"
I RECORD("TYPE")=3 D S TIUVALID=$S(TIUVALID["^":"NO",1:"YES") I TIUVALID="NO" D FAIL Q
. ; added $G to CHK below ; *335 ajb
. D CHK^DIE(8925,1307,,$G(TIUHDR("TIUDDT")),.TIUVALID) I TIUVALID["^" Q
. D CHK^DIE(8925,1202,,$G(TIUHDR(1202)),.TIUVALID)
; ---- If a LOOKUP METHOD is defined for a given document type,
; then set lookup variables and call it:
I $G(TIUD4)]"",TIUVALID="YES" D Q
. N TIUJ,TIUVAR,TIUNOD S TIUVAR="A"
. F S TIUVAR=$O(TIUHDR(TIUVAR)) Q:TIUVAR="" D
. . S TIUJ=+$G(TIUJ)+1,TIUVAR(TIUJ)=TIUVAR
. . S @TIUVAR=TIUHDR(TIUVAR)
. X TIUD4 S RECORD("#")=+Y
. I +Y'>0 D FAIL
. ; ---- Kill local lookup variables:
. S TIUJ=0 F S TIUJ=$O(TIUVAR(TIUJ)) Q:+TIUJ'>0 K @TIUVAR(TIUJ)
; Otherwise set-up for ^DIC call
S DIC=RECORD("FILE"),DIC(0)="MX"
S:+$P(TIUD1,U,2) DIC(0)=DIC(0)_"L"
S:+$G(TIUHDR(.001)) DIC(0)=DIC(0)_"N"
S TIUKEY=$S(+$G(TIUHDR(.001)):+$G(TIUHDR(.001)),1:$G(TIUHDR(.01)))
S X=$S(DIC(0)["N":"`",1:"")_TIUKEY D ^DIC
S RECORD("#")=+Y
I +Y'>0 D
. D MAIN^TIUPEVNT(DA,1,6,$P($G(^TIU(8925.1,+RECORD("TYPE"),0)),U))
. ;W:'$D(ZTQUEUED) !!,"LOOK-UP FAILED FOR ",X,".",!
. S ^TMP("TIUPUTC",$J,"FAIL")=+$G(^TMP("TIUPUTC",$J,"FAIL"))+1
Q
;
FAIL ; Log Filing Error
; ---- If lookup fails, log 8925.4 error w/ hdr info. Create new
; 8925.2 buffer entry with hdr, text, & 8925.4 log #.
; Kill most of old buffer. Send file error alerts:
D MAIN^TIUPEVNT(DA,1,6,$P($G(^TIU(8925.1,+RECORD("TYPE"),0)),U))
;W:'$D(ZTQUEUED) !!,"LOOK-UP FAILED FOR ",X,".",!
S ^TMP("TIUPUTC",$J,"FAIL")=+$G(^TMP("TIUPUTC",$J,"FAIL"))+1
Q
;
DICTDT(DATE) ;TEST** -- Returns 1 if Discharge Summary's Dictation Date is in the future, 0 otherwise
N %,X,Y,%DT
S X=DATE,%DT="T" D ^%DT Q:Y=-1 0 D NOW^%DTC Q Y>%
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPUTC1 4827 printed Apr 09, 2024@21:48:49 Page 2
TIUPUTC1 ; SLC/JER,AJB - Document filer Cont'd - captioned header ;Jul 09, 2020@12:06:28
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**81,290,335**;Jun 20, 1997;Build 3
+2 ;
GETREC(HEADER,RECORD,TIUHDR) ; ---- Look-up/create record (if LAYGO allowed)
+1 NEW DIC,DLAYGO,TIUD1,TIUD4,TIUKEY,X,Y,TIUDSFTR
+2 IF '$DATA(ZTQUEUED)
WRITE !!,">>> HEADER IDENTIFIED:",!,HEADER
+3 SET X=$$STRIP^TIULS($PIECE(HEADER,":",2))
SET Y=$$WHATYPE^TIUPUTU(X)
+4 IF +Y'>0
DO MAIN^TIUPEVNT(DA,1,3,X)
Begin DoDot:1
+5 if '$DATA(ZTQUEUED)
WRITE !!,"INVALID DOCUMENT TYPE ",X,".",!
+6 SET ^TMP("TIUPUTC",$JOB,"FAIL")=+$GET(^TMP("TIUPUTC",$JOB,"FAIL"))+1
End DoDot:1
QUIT
+7 SET TIUD1=$GET(^TIU(8925.1,+Y,1))
SET TIUD4=$GET(^TIU(8925.1,+Y,4))
+8 SET RECORD("TYPE")=+Y
SET RECORD("FILE")=$PIECE(TIUD1,U)
+9 SET RECORD("BOILON")=$PIECE(TIUD1,U,4)
+10 IF RECORD("FILE")']""
DO MAIN^TIUPEVNT(DA,1,4,X)
Begin DoDot:1
+11 if '$DATA(ZTQUEUED)
WRITE !!,"TARGET FILE NOT DEFINED FOR ",X,".",!
+12 SET ^TMP("TIUPUTC",$JOB,"FAIL")=+$GET(^TMP("TIUPUTC",$JOB,"FAIL"))+1
End DoDot:1
QUIT
+13 SET RECORD("ROOT")=$GET(^DIC(+RECORD("FILE"),0,"GL"))
+14 IF $PIECE(TIUD1,U,3)']""
DO MAIN^TIUPEVNT(DA,1,5,X)
Begin DoDot:1
+15 if '$DATA(ZTQUEUED)
WRITE !!,"TEXT FIELD NOT DEFINED FOR ",X,".",!
+16 SET ^TMP("TIUPUTC",$JOB,"FAIL")=+$GET(^TMP("TIUPUTC",$JOB,"FAIL"))+1
End DoDot:1
QUIT
+17 IF $PIECE(TIUD1,U,3)]""
Begin DoDot:1
+18 ; ---- Get subscript of target file TEXT field
+19 SET RECORD("TEXT")=$PIECE($PIECE(TIUD1,U,3),";",2)
+20 IF RECORD("TEXT")]""
IF '+RECORD("TEXT")
SET RECORD("TEXT")=""""_RECORD("TEXT")_""""
End DoDot:1
+21 FOR
Begin DoDot:1
+22 NEW TIUNOD,TIUCAP,TIUVAR,TIUFIELD,TIUREQ
SET TIUREQ=0
+23 ; ---- Reset TIUI and Write out transferred header info:
+24 SET TIUI=$ORDER(^TIU(8925.2,+DA,"TEXT",TIUI))
if +TIUI'>0
QUIT
+25 SET TIULINE=$GET(^TIU(8925.2,+DA,"TEXT",TIUI,0))
if TIULINE[TIUBGN
QUIT
+26 IF '$DATA(ZTQUEUED)
WRITE !,TIULINE
+27 ; ---- Check for field number, required missing fields:
+28 SET TIUCAP=$PIECE(TIULINE,":")
if TIUCAP']""
QUIT
+29 SET TIUNOD=$ORDER(^TIU(8925.1,+RECORD("TYPE"),"HEAD","B",TIUCAP,0))
if +TIUNOD'>0
QUIT
+30 SET TIUFIELD=$PIECE(^TIU(8925.1,+RECORD("TYPE"),"HEAD",+TIUNOD,0),U,3)
+31 IF TIUFIELD']""
if '$DATA(ZTQUEUED)
WRITE !,"Field Number NOT SPECIFIED for ",TIUCAP
QUIT
+32 SET TIUREQ=$PIECE(^TIU(8925.1,+RECORD("TYPE"),"HEAD",+TIUNOD,0),U,7)
+33 SET TIUHDR(TIUFIELD)=$$STRIP^TIULS($PIECE(TIULINE,":",2,99))
+34 ;**TEST** - No future dictation dates for discharge summaries
+35 IF TIUFIELD=1307
IF $$ISA^TIULX($GET(TIUREC("TYPE")),$$CHKFILE^TIUADCL(8925.1,"DISCHARGE SUMMARY","I $P(^(0),U,4)=""CL"""))
IF $GET(TIUHDR("1307"))]""
SET TIUDSFTR=$$DICTDT(TIUHDR("1307"))
IF TIUDSFTR
Begin DoDot:2
+36 SET TIUHDR(TIUFIELD)=""
IF '$DATA(ZTQUEUED)
WRITE !,"**Future dictation dates are not allowed for this type of document**"
SET TIUFDT=1
SET ^TMP("TIUPUTC",$JOB,"FAIL")=+$GET(^TMP("TIUPUTC",$JOB,"FAIL"))+1
QUIT
End DoDot:2
QUIT
+37 IF +TIUREQ
IF TIUHDR(TIUFIELD)=""
SET TIUHDR(TIUFIELD)="** REQUIRED FIELD MISSING FROM UPLOAD **"
+38 ; ---- Get local lookup variables for document type:
+39 SET TIUVAR=$PIECE(^TIU(8925.1,+RECORD("TYPE"),"HEAD",+TIUNOD,0),U,4)
if TIUVAR']""
QUIT
+40 SET TIUHDR(TIUVAR)=$$STRIP^TIULS($PIECE(TIULINE,":",2,99))
End DoDot:1
if TIULINE[TIUBGN!(+TIUI'>0)
QUIT
+41 if TIUFDT=1
QUIT
IF '$DATA(ZTQUEUED)
WRITE !,TIUBGN,!
+42 if +$PIECE(TIUD1,U,2)
SET DLAYGO=RECORD("FILE")
+43 ; Can't check if author Requires EC w/o Dict dt & AUTHOR so if not valid set FILING ERROR:
+44 NEW TIUVALID
SET TIUVALID="YES"
+45 IF RECORD("TYPE")=3
Begin DoDot:1
+46 ; added $G to CHK below ; *335 ajb
+47 DO CHK^DIE(8925,1307,,$GET(TIUHDR("TIUDDT")),.TIUVALID)
IF TIUVALID["^"
QUIT
+48 DO CHK^DIE(8925,1202,,$GET(TIUHDR(1202)),.TIUVALID)
End DoDot:1
SET TIUVALID=$SELECT(TIUVALID["^":"NO",1:"YES")
IF TIUVALID="NO"
DO FAIL
QUIT
+49 ; ---- If a LOOKUP METHOD is defined for a given document type,
+50 ; then set lookup variables and call it:
+51 IF $GET(TIUD4)]""
IF TIUVALID="YES"
Begin DoDot:1
+52 NEW TIUJ,TIUVAR,TIUNOD
SET TIUVAR="A"
+53 FOR
SET TIUVAR=$ORDER(TIUHDR(TIUVAR))
if TIUVAR=""
QUIT
Begin DoDot:2
+54 SET TIUJ=+$GET(TIUJ)+1
SET TIUVAR(TIUJ)=TIUVAR
+55 SET @TIUVAR=TIUHDR(TIUVAR)
End DoDot:2
+56 XECUTE TIUD4
SET RECORD("#")=+Y
+57 IF +Y'>0
DO FAIL
+58 ; ---- Kill local lookup variables:
+59 SET TIUJ=0
FOR
SET TIUJ=$ORDER(TIUVAR(TIUJ))
if +TIUJ'>0
QUIT
KILL @TIUVAR(TIUJ)
End DoDot:1
QUIT
+60 ; Otherwise set-up for ^DIC call
+61 SET DIC=RECORD("FILE")
SET DIC(0)="MX"
+62 if +$PIECE(TIUD1,U,2)
SET DIC(0)=DIC(0)_"L"
+63 if +$GET(TIUHDR(.001))
SET DIC(0)=DIC(0)_"N"
+64 SET TIUKEY=$SELECT(+$GET(TIUHDR(.001)):+$GET(TIUHDR(.001)),1:$GET(TIUHDR(.01)))
+65 SET X=$SELECT(DIC(0)["N":"`",1:"")_TIUKEY
DO ^DIC
+66 SET RECORD("#")=+Y
+67 IF +Y'>0
Begin DoDot:1
+68 DO MAIN^TIUPEVNT(DA,1,6,$PIECE($GET(^TIU(8925.1,+RECORD("TYPE"),0)),U))
+69 ;W:'$D(ZTQUEUED) !!,"LOOK-UP FAILED FOR ",X,".",!
+70 SET ^TMP("TIUPUTC",$JOB,"FAIL")=+$GET(^TMP("TIUPUTC",$JOB,"FAIL"))+1
End DoDot:1
+71 QUIT
+72 ;
FAIL ; Log Filing Error
+1 ; ---- If lookup fails, log 8925.4 error w/ hdr info. Create new
+2 ; 8925.2 buffer entry with hdr, text, & 8925.4 log #.
+3 ; Kill most of old buffer. Send file error alerts:
+4 DO MAIN^TIUPEVNT(DA,1,6,$PIECE($GET(^TIU(8925.1,+RECORD("TYPE"),0)),U))
+5 ;W:'$D(ZTQUEUED) !!,"LOOK-UP FAILED FOR ",X,".",!
+6 SET ^TMP("TIUPUTC",$JOB,"FAIL")=+$GET(^TMP("TIUPUTC",$JOB,"FAIL"))+1
+7 QUIT
+8 ;
DICTDT(DATE) ;TEST** -- Returns 1 if Discharge Summary's Dictation Date is in the future, 0 otherwise
+1 NEW %,X,Y,%DT
+2 SET X=DATE
SET %DT="T"
DO ^%DT
if Y=-1
QUIT 0
DO NOW^%DTC
QUIT Y>%
+3 ;
