- 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 Feb 19, 2025@00:11:04 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 ;
