TIUCPFIX ; SLC/JER,RMO - Resolve Filing errors for CP Documents ;4/18/03
;;1.0;TEXT INTEGRATION UTILITIES;**109,167,113**;Jun 20, 1997
; This routine is a modified version of TIUPEFIX
MAKE(SUCCESS,DFN,TITLE,TIU,TIUBUF,TIUPLDA) ; File new TIU Document
; SUCCESS = (by ref) SUCCESS Returns TIU DOCUMENT # (PTR to 8925)
; = 0^Explanatory message if no SUCCESS
; DFN = Patient (#2)
; TITLE = Pointer to TIU Document Definition (#8925.1)
; TIU = Array of demographic and visit attributes
; TIUBUF = Record number (ien) of entry in TIU Buffer file (#8925.2)
; TIUPLDA = Record number (ien) of entry in TIU Document file (#8925) (Optional)
;
; -- first, get TIU Document record --
;
N TIUDA,LDT,NEWREC,TIUX,TIUTYP,TIUDPRM,HAPPY,TIUCLASS,TIUDTYP,TIUPOST
N TIUDFLT,TIUREC,TIUCNNBR,TIUDNB,TIUDTP,TIUPSC,TIUQUIT
S SUCCESS=0 ; Initialize SUCCESS to false
I '$G(TIUPLDA) D G MAKEQ:$G(TIUQUIT)
. I $S($D(TIU)'>9:1,+$G(DFN)'>0:1,+$G(TIUTYPE)'>0:1,1:0) S SUCCESS="0^"_$$EZBLD^DIALOG(89250001) S TIUQUIT=1 Q
. ; If target file is not 8925 QUIT
. I +$G(^TIU(8925.1,+TIUTYPE,1))'=8925 S TIUQUIT=1 Q
. S TIUDTYP=$P($G(^TIU(8925.1,+TIUTYPE,0)),U,4)
. S TIUCLASS=$S(TIUDTYP="CL":+TIUTYPE,1:38)
. S TIUDFLT=$S(TIUCLASS'=TIUTYPE:TIUTYPE,1:"")
. I +$G(TITLE)'>0 S TITLE=$$ASKTITLE^TIULA3(TIUCLASS,TIUDFLT)
. I +TITLE'>0 S TIUQUIT=1 Q
ELSE D
. S TITLE=+$G(^TIU(8925,+TIUPLDA,0))
S TIUTYP=TITLE,TIUTYP(1)=1_U_TITLE
D DOCPRM^TIULC1(TITLE,.TIUDPRM)
;
; -- second, load the header elements & text into TIUX array
;
D LOADTIUX(.TIUX,TIUBUF)
;
;Set variables
I $G(TIUPLDA) D
. S TIUCNNBR=+$P($G(^TIU(8925,+TIUPLDA,14)),U,5)
ELSE D
. S TIUCNNBR=$S(+$P($G(TIUX(1405)),"C.",2):+$P($G(TIUX(1405)),"C.",2),1:"")
. S:$G(TIUX(.001)) TIUPLDA=$G(TIUX(.001))
S TIUPSC=$G(TIUX(70201))
S TIUDTP=$G(TIUX(70202))
;
;Check consult associated with document
I '$$CHKCN^TIUPUTCP(TIUCNNBR,DFN,$G(TIUPLDA),.TIUDNB) S SUCCESS="0^"_$$EZBLD^DIALOG($G(TIUDNB)) G MAKEQ
;
;Check consult as it related to CP
I '$$CHKCP^TIUPUTCP(TIUCNNBR,$G(TIUPLDA),.TIUDNB) S SUCCESS="0^"_$$EZBLD^DIALOG($G(TIUDNB)) G MAKEQ
;
;If TIU document IEN is defined use it, otherwise call TIUEDI3
I $G(TIUPLDA) D
. S TIUDA=TIUPLDA
ELSE D
. S TIUDA=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.NEWREC,.TIUDPRM)
I +TIUDA'>0 S SUCCESS="0^"_$$EZBLD^DIALOG(89250002) G MAKEQ
I +$$CANEDIT^TIUPUTU(TIUDA)'>0 D G MAKEX
. D MAKEADD(.TIUADD,+TIUDA,TIUBUF) S SUCCESS=TIUADD
S SUCCESS=1
;
D STUFREC(TIUDA,$G(DFN),,.TIU,$G(TIUPSC),$G(TIUDTP),$G(TIUPLDA))
;
; -- third, file the data in TIU Document record --
;
K ^TIU(8925,+TIUDA,"TEMP"),TIUX(.01),TIUX(.02),TIUX(.03),TIUX(.05)
K TIUX(.13),TIUX(1205),TIUX(1211),TIUX(.001),TIUX(70201),TIUX(70202)
M ^TIU(8925,+TIUDA,"TEMP")=TIUX("TEXT") K TIUX("TEXT")
D FILE(.HAPPY,+TIUDA,.TIUX,TIUTYP)
D MERGTEXT^TIUEDI1(+TIUDA,.TIU)
S TIUPOST=$$POSTFILE^TIULC1(TITLE)
S TIUREC("#")=TIUDA
I TIUPOST]"" X TIUPOST
MAKEX D ALERTDEL^TIUPEVNT(+TIUBUF)
D RESOLVE^TIUPEVNT($S($D(XQADATA):+$P(XQADATA,";",3),1:$G(ERRDA)),1)
D BUFPURGE^TIUPUTC(+TIUBUF)
K ^TIU(8925,+TIUDA,"TEMP") W "Done."
I +$G(TIUDA),+$D(^TIU(8925,+$G(TIUDA),0)) D
. N TIU D GETTIU^TIULD(.TIU,+TIUDA)
. D EN^VALM("TIU BROWSE FOR MRT")
MAKEQ Q
LOADTIUX(TIUARR,TIUBUF) ; Load TIUX array with header and text
N TIUI,TIUHSIG,TIUBGN,TIULINE,X,Y,TYPE I '$D(TIUPRM0) D SETPARM^TIULE
S TIUHSIG=$P(TIUPRM0,U,10),TIUBGN=$P(TIUPRM0,U,12)
S TIUI=0 F S TIUI=$O(^TIU(8925.2,+TIUBUF,"TEXT",TIUI)) Q:+TIUI'>0 D
. S TIULINE=$G(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0))
. I TIULINE[TIUHSIG D
. . N TIUD1,TIUD4
. . S X=$$STRIP^TIULS($P(TIULINE,":",2)),Y=$$WHATYPE^TIUPUTU(X)
. . I +Y'>0 D MAIN^TIUPEVNT(TIUBUF,1,3,X) Q
. . S TIUD1=$G(^TIU(8925.1,+Y,1)),TIUD4=$G(^TIU(8925.1,+Y,4))
. . S TYPE=+Y
. . F D Q:TIULINE[TIUBGN!(+TIUI'>0)
. . . N TIUN,TIUCAP,TIUFLD,TIUREQ S TIUREQ=0
. . . S TIUI=$O(^TIU(8925.2,+TIUBUF,"TEXT",TIUI)) Q:+TIUI'>0
. . . S TIULINE=$G(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0)) Q:TIULINE[TIUBGN
. . . S TIUCAP=$P(TIULINE,":") Q:TIUCAP']""
. . . S TIUN=$O(^TIU(8925.1,+TYPE,"HEAD","B",TIUCAP,0))
. . . Q:+TIUN'>0
. . . S TIUFLD=$P(^TIU(8925.1,+TYPE,"HEAD",+TIUN,0),U,3)
. . . Q:TIUFLD']""
. . . S TIUREQ=$P(^TIU(8925.1,+TYPE,"HEAD",+TIUN,0),U,7)
. . . S TIUARR(TIUFLD)=$$STRIP^TIULS($P(TIULINE,":",2,99))
. . . S:TIUFLD'=.001 TIUARR(TIUFLD)=$$TRNSFRM(+TYPE,TIUFLD,TIUARR(TIUFLD))
. . . I +TIUREQ,TIUARR(TIUFLD)="" S TIUARR(TIUFLD)="** REQUIRED FIELD MISSING FROM UPLOAD **"
. . . I $S(TIUFLD=.01:1,TIUFLD=.02:1,TIUFLD=.07:1,TIUFLD=1301:1,1:0) K TIUARR(TIUFLD)
. . I TIULINE[TIUBGN D
. . . N TIUJ S TIUJ=0
. . . F D Q:+TIUI'>0
. . . . S TIUI=$O(^TIU(8925.2,+TIUBUF,"TEXT",TIUI)) Q:+TIUI'>0
. . . . S TIUJ=TIUJ+1
. . . . S TIUARR("TEXT",TIUJ,0)=$G(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0))
Q
STUFREC(DA,DFN,PARENT,TIU,TIUPSC,TIUDTP,TIUPLDA) ; Stuff fixed field data
N FDA,FDARR,IENS,FLAGS,TIUMSG,TIURDT,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(TIU("EDT"),U)
. . S @FDARR@(1401)=$P($G(TIU("AD#")),U),@FDARR@(1402)=$P($G(TIU("TS")),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@(1212)=$S(+$P($G(TIU("INST")),U):$P($G(TIU("INST")),U),1:DUZ(2))
. . S @FDARR@(1404)=$P($G(TIU("SVC")),U)
. S @FDARR@(.05)=$S(+$$REQVER(+$P($G(TIUDPRM(0)),U,3)):4,1:5)
. S @FDARR@(.08)=$P(TIU("LDT"),U)
I +$G(PARENT)>0 D
. S @FDARR@(.02)=+$P(^TIU(8925,+PARENT,0),U,2)
. S @FDARR@(.03)=$P(^TIU(8925,+PARENT,0),U,3)
. S @FDARR@(.05)=$S(+$$REQVER(+$P($G(TIUDPRM(0)),U,3)):4,1:5)
. S @FDARR@(.06)=PARENT
. S @FDARR@(.07)=$P($G(TIU("EDT")),U),@FDARR@(.08)=$P($G(TIU("LDT")),U)
. S @FDARR@(1205)=$P($G(^TIU(8925,+PARENT,12)),U,5)
. S @FDARR@(1212)=$P($G(^TIU(8925,+PARENT,12)),U,12)
. S @FDARR@(1401)=$P($G(^TIU(8925,+PARENT,14)),U)
. S @FDARR@(1402)=$P($G(^TIU(8925,+PARENT,14)),U,2)
. S @FDARR@(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4)
. S @FDARR@(1201)=$$NOW^XLFDT
I +$G(TIU("LDT")) S TIURDT=+$G(TIU("LDT"))
I +$G(TIU("LDT"))'>0 D
. S TIUDICDT=+$$IDATE^TIULC($G(TIUDICDT))
. I +TIUDICDT,($P(TIUDICDT,".",2)'>0) D
. . S TIUDICDT=$S($P(TIU("VSTR"),";",3)'="H":$P($G(TIU("EDT")),U),1:"")
. S TIURDT=$S(+$G(TIUDICDT)>0:+$G(TIUDICDT),1:+$$NOW^TIULC)
. S:+$G(TIUTYPE)=1 @FDARR@(.12)=1
. K TIUDICDT
I '$G(TIUPLDA) S @FDARR@(1301)=TIURDT
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")
Q
REQVER(VPARM) ; Evaluate whether verification is required
Q $S(VPARM=1:1,VPARM=2:1,1:0)
MAKEADD(TIUDADD,TIUDA,TIUBUF) ; Create an addendum record
N DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUCAN,TIUFPRIV,TIU,TIUX S TIUFPRIV=1
N TIUDTTL,TIUPOST,TIUREC
S TIUDTTL=+$G(^TIU(8925,+TIUDA,0))
S TIUATYP=+$$WHATITLE^TIUPUTU("ADDENDUM")
S (DIC,DLAYGO)=8925,DIC(0)="L",X=""""_"`"_TIUATYP_""""
D ^DIC
S TIUDADD=+Y
I +Y'>0 S TIUDADD=TIUDADD_"^Could not create addendum." Q
D GETTIU^TIULD(.TIU,TIUDA)
S TIU("DOCTYP")=TIUATYP_U_$$PNAME^TIULC1(TIUATYP)
D STUFREC(TIUDADD,DFN,+TIUDA,.TIU)
D LOADTIUX(.TIUX,TIUBUF)
K ^TIU(8925,+TIUDADD,"TEMP")
M ^TIU(8925,+TIUDADD,"TEMP")=TIUX("TEXT") K TIUX("TEXT")
D FILE(.SUCCESS,+TIUDADD,.TIUX,TIUATYP)
D MERGTEXT^TIUEDI1(+TIUDADD,.TIU)
S TIUPOST=$$POSTFILE^TIULC1(TIUDTTL)
S TIUREC("#")=TIUDADD
I TIUPOST]"" X TIUPOST
K ^TIU(8925,+TIUDADD,"TEMP")
Q
FILE(SUCCESS,TIUDA,TIUX,RTYPE) ; Call FM Filer to commit updates to DB
N FDA,FDARR,IENS,FLAGS,TIUMSG
S IENS=""""_TIUDA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="KE"
M @FDARR=TIUX
D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
I $D(TIUMSG)>9 D
. S SUCCESS=0_U_$G(TIUMSG("DIERR",1,"TEXT",1))
. D MAIN^TIUPEVNT(TIUBUF,2,"",$P($G(^TIU(8925.1,+RTYPE,0)),U),.FDA,.TIUMSG)
E S SUCCESS=TIUDA
Q
TRNSFRM(RTYPE,FLD,X) ; Executes Transform code for a given header field
N XFORM
S FLD=$O(^TIU(8925.1,+RTYPE,"HEAD","D",+FLD,0))
I +FLD'>0 G TRNSFRMX
S XFORM=$G(^TIU(8925.1,+RTYPE,"HEAD",+FLD,1))
I XFORM']"" G TRNSFRMX
X XFORM
TRNSFRMX Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUCPFIX 8555 printed Apr 09, 2024@21:47:21 Page 2
TIUCPFIX ; SLC/JER,RMO - Resolve Filing errors for CP Documents ;4/18/03
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**109,167,113**;Jun 20, 1997
+2 ; This routine is a modified version of TIUPEFIX
MAKE(SUCCESS,DFN,TITLE,TIU,TIUBUF,TIUPLDA) ; File new TIU Document
+1 ; SUCCESS = (by ref) SUCCESS Returns TIU DOCUMENT # (PTR to 8925)
+2 ; = 0^Explanatory message if no SUCCESS
+3 ; DFN = Patient (#2)
+4 ; TITLE = Pointer to TIU Document Definition (#8925.1)
+5 ; TIU = Array of demographic and visit attributes
+6 ; TIUBUF = Record number (ien) of entry in TIU Buffer file (#8925.2)
+7 ; TIUPLDA = Record number (ien) of entry in TIU Document file (#8925) (Optional)
+8 ;
+9 ; -- first, get TIU Document record --
+10 ;
+11 NEW TIUDA,LDT,NEWREC,TIUX,TIUTYP,TIUDPRM,HAPPY,TIUCLASS,TIUDTYP,TIUPOST
+12 NEW TIUDFLT,TIUREC,TIUCNNBR,TIUDNB,TIUDTP,TIUPSC,TIUQUIT
+13 ; Initialize SUCCESS to false
SET SUCCESS=0
+14 IF '$GET(TIUPLDA)
Begin DoDot:1
+15 IF $SELECT($DATA(TIU)'>9:1,+$GET(DFN)'>0:1,+$GET(TIUTYPE)'>0:1,1:0)
SET SUCCESS="0^"_$$EZBLD^DIALOG(89250001)
SET TIUQUIT=1
QUIT
+16 ; If target file is not 8925 QUIT
+17 IF +$GET(^TIU(8925.1,+TIUTYPE,1))'=8925
SET TIUQUIT=1
QUIT
+18 SET TIUDTYP=$PIECE($GET(^TIU(8925.1,+TIUTYPE,0)),U,4)
+19 SET TIUCLASS=$SELECT(TIUDTYP="CL":+TIUTYPE,1:38)
+20 SET TIUDFLT=$SELECT(TIUCLASS'=TIUTYPE:TIUTYPE,1:"")
+21 IF +$GET(TITLE)'>0
SET TITLE=$$ASKTITLE^TIULA3(TIUCLASS,TIUDFLT)
+22 IF +TITLE'>0
SET TIUQUIT=1
QUIT
End DoDot:1
if $GET(TIUQUIT)
GOTO MAKEQ
+23 IF '$TEST
Begin DoDot:1
+24 SET TITLE=+$GET(^TIU(8925,+TIUPLDA,0))
End DoDot:1
+25 SET TIUTYP=TITLE
SET TIUTYP(1)=1_U_TITLE
+26 DO DOCPRM^TIULC1(TITLE,.TIUDPRM)
+27 ;
+28 ; -- second, load the header elements & text into TIUX array
+29 ;
+30 DO LOADTIUX(.TIUX,TIUBUF)
+31 ;
+32 ;Set variables
+33 IF $GET(TIUPLDA)
Begin DoDot:1
+34 SET TIUCNNBR=+$PIECE($GET(^TIU(8925,+TIUPLDA,14)),U,5)
End DoDot:1
+35 IF '$TEST
Begin DoDot:1
+36 SET TIUCNNBR=$SELECT(+$PIECE($GET(TIUX(1405)),"C.",2):+$PIECE($GET(TIUX(1405)),"C.",2),1:"")
+37 if $GET(TIUX(.001))
SET TIUPLDA=$GET(TIUX(.001))
End DoDot:1
+38 SET TIUPSC=$GET(TIUX(70201))
+39 SET TIUDTP=$GET(TIUX(70202))
+40 ;
+41 ;Check consult associated with document
+42 IF '$$CHKCN^TIUPUTCP(TIUCNNBR,DFN,$GET(TIUPLDA),.TIUDNB)
SET SUCCESS="0^"_$$EZBLD^DIALOG($GET(TIUDNB))
GOTO MAKEQ
+43 ;
+44 ;Check consult as it related to CP
+45 IF '$$CHKCP^TIUPUTCP(TIUCNNBR,$GET(TIUPLDA),.TIUDNB)
SET SUCCESS="0^"_$$EZBLD^DIALOG($GET(TIUDNB))
GOTO MAKEQ
+46 ;
+47 ;If TIU document IEN is defined use it, otherwise call TIUEDI3
+48 IF $GET(TIUPLDA)
Begin DoDot:1
+49 SET TIUDA=TIUPLDA
End DoDot:1
+50 IF '$TEST
Begin DoDot:1
+51 SET TIUDA=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.NEWREC,.TIUDPRM)
End DoDot:1
+52 IF +TIUDA'>0
SET SUCCESS="0^"_$$EZBLD^DIALOG(89250002)
GOTO MAKEQ
+53 IF +$$CANEDIT^TIUPUTU(TIUDA)'>0
Begin DoDot:1
+54 DO MAKEADD(.TIUADD,+TIUDA,TIUBUF)
SET SUCCESS=TIUADD
End DoDot:1
GOTO MAKEX
+55 SET SUCCESS=1
+56 ;
+57 DO STUFREC(TIUDA,$GET(DFN),,.TIU,$GET(TIUPSC),$GET(TIUDTP),$GET(TIUPLDA))
+58 ;
+59 ; -- third, file the data in TIU Document record --
+60 ;
+61 KILL ^TIU(8925,+TIUDA,"TEMP"),TIUX(.01),TIUX(.02),TIUX(.03),TIUX(.05)
+62 KILL TIUX(.13),TIUX(1205),TIUX(1211),TIUX(.001),TIUX(70201),TIUX(70202)
+63 MERGE ^TIU(8925,+TIUDA,"TEMP")=TIUX("TEXT")
KILL TIUX("TEXT")
+64 DO FILE(.HAPPY,+TIUDA,.TIUX,TIUTYP)
+65 DO MERGTEXT^TIUEDI1(+TIUDA,.TIU)
+66 SET TIUPOST=$$POSTFILE^TIULC1(TITLE)
+67 SET TIUREC("#")=TIUDA
+68 IF TIUPOST]""
XECUTE TIUPOST
MAKEX DO ALERTDEL^TIUPEVNT(+TIUBUF)
+1 DO RESOLVE^TIUPEVNT($SELECT($DATA(XQADATA):+$PIECE(XQADATA,";",3),1:$GET(ERRDA)),1)
+2 DO BUFPURGE^TIUPUTC(+TIUBUF)
+3 KILL ^TIU(8925,+TIUDA,"TEMP")
WRITE "Done."
+4 IF +$GET(TIUDA)
IF +$DATA(^TIU(8925,+$GET(TIUDA),0))
Begin DoDot:1
+5 NEW TIU
DO GETTIU^TIULD(.TIU,+TIUDA)
+6 DO EN^VALM("TIU BROWSE FOR MRT")
End DoDot:1
MAKEQ QUIT
LOADTIUX(TIUARR,TIUBUF) ; Load TIUX array with header and text
+1 NEW TIUI,TIUHSIG,TIUBGN,TIULINE,X,Y,TYPE
IF '$DATA(TIUPRM0)
DO SETPARM^TIULE
+2 SET TIUHSIG=$PIECE(TIUPRM0,U,10)
SET TIUBGN=$PIECE(TIUPRM0,U,12)
+3 SET TIUI=0
FOR
SET TIUI=$ORDER(^TIU(8925.2,+TIUBUF,"TEXT",TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+4 SET TIULINE=$GET(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0))
+5 IF TIULINE[TIUHSIG
Begin DoDot:2
+6 NEW TIUD1,TIUD4
+7 SET X=$$STRIP^TIULS($PIECE(TIULINE,":",2))
SET Y=$$WHATYPE^TIUPUTU(X)
+8 IF +Y'>0
DO MAIN^TIUPEVNT(TIUBUF,1,3,X)
QUIT
+9 SET TIUD1=$GET(^TIU(8925.1,+Y,1))
SET TIUD4=$GET(^TIU(8925.1,+Y,4))
+10 SET TYPE=+Y
+11 FOR
Begin DoDot:3
+12 NEW TIUN,TIUCAP,TIUFLD,TIUREQ
SET TIUREQ=0
+13 SET TIUI=$ORDER(^TIU(8925.2,+TIUBUF,"TEXT",TIUI))
if +TIUI'>0
QUIT
+14 SET TIULINE=$GET(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0))
if TIULINE[TIUBGN
QUIT
+15 SET TIUCAP=$PIECE(TIULINE,":")
if TIUCAP']""
QUIT
+16 SET TIUN=$ORDER(^TIU(8925.1,+TYPE,"HEAD","B",TIUCAP,0))
+17 if +TIUN'>0
QUIT
+18 SET TIUFLD=$PIECE(^TIU(8925.1,+TYPE,"HEAD",+TIUN,0),U,3)
+19 if TIUFLD']""
QUIT
+20 SET TIUREQ=$PIECE(^TIU(8925.1,+TYPE,"HEAD",+TIUN,0),U,7)
+21 SET TIUARR(TIUFLD)=$$STRIP^TIULS($PIECE(TIULINE,":",2,99))
+22 if TIUFLD'=.001
SET TIUARR(TIUFLD)=$$TRNSFRM(+TYPE,TIUFLD,TIUARR(TIUFLD))
+23 IF +TIUREQ
IF TIUARR(TIUFLD)=""
SET TIUARR(TIUFLD)="** REQUIRED FIELD MISSING FROM UPLOAD **"
+24 IF $SELECT(TIUFLD=.01:1,TIUFLD=.02:1,TIUFLD=.07:1,TIUFLD=1301:1,1:0)
KILL TIUARR(TIUFLD)
End DoDot:3
if TIULINE[TIUBGN!(+TIUI'>0)
QUIT
+25 IF TIULINE[TIUBGN
Begin DoDot:3
+26 NEW TIUJ
SET TIUJ=0
+27 FOR
Begin DoDot:4
+28 SET TIUI=$ORDER(^TIU(8925.2,+TIUBUF,"TEXT",TIUI))
if +TIUI'>0
QUIT
+29 SET TIUJ=TIUJ+1
+30 SET TIUARR("TEXT",TIUJ,0)=$GET(^TIU(8925.2,+TIUBUF,"TEXT",TIUI,0))
End DoDot:4
if +TIUI'>0
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+31 QUIT
STUFREC(DA,DFN,PARENT,TIU,TIUPSC,TIUDTP,TIUPLDA) ; Stuff fixed field data
+1 NEW FDA,FDARR,IENS,FLAGS,TIUMSG,TIURDT,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(TIU("EDT"),U)
+7 SET @FDARR@(1401)=$PIECE($GET(TIU("AD#")),U)
SET @FDARR@(1402)=$PIECE($GET(TIU("TS")),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@(1212)=$SELECT(+$PIECE($GET(TIU("INST")),U):$PIECE($GET(TIU("INST")),U),1:DUZ(2))
+11 SET @FDARR@(1404)=$PIECE($GET(TIU("SVC")),U)
End DoDot:2
+12 SET @FDARR@(.05)=$SELECT(+$$REQVER(+$PIECE($GET(TIUDPRM(0)),U,3)):4,1:5)
+13 SET @FDARR@(.08)=$PIECE(TIU("LDT"),U)
End DoDot:1
+14 IF +$GET(PARENT)>0
Begin DoDot:1
+15 SET @FDARR@(.02)=+$PIECE(^TIU(8925,+PARENT,0),U,2)
+16 SET @FDARR@(.03)=$PIECE(^TIU(8925,+PARENT,0),U,3)
+17 SET @FDARR@(.05)=$SELECT(+$$REQVER(+$PIECE($GET(TIUDPRM(0)),U,3)):4,1:5)
+18 SET @FDARR@(.06)=PARENT
+19 SET @FDARR@(.07)=$PIECE($GET(TIU("EDT")),U)
SET @FDARR@(.08)=$PIECE($GET(TIU("LDT")),U)
+20 SET @FDARR@(1205)=$PIECE($GET(^TIU(8925,+PARENT,12)),U,5)
+21 SET @FDARR@(1212)=$PIECE($GET(^TIU(8925,+PARENT,12)),U,12)
+22 SET @FDARR@(1401)=$PIECE($GET(^TIU(8925,+PARENT,14)),U)
+23 SET @FDARR@(1402)=$PIECE($GET(^TIU(8925,+PARENT,14)),U,2)
+24 SET @FDARR@(1404)=$PIECE($GET(^TIU(8925,+PARENT,14)),U,4)
+25 SET @FDARR@(1201)=$$NOW^XLFDT
End DoDot:1
+26 IF +$GET(TIU("LDT"))
SET TIURDT=+$GET(TIU("LDT"))
+27 IF +$GET(TIU("LDT"))'>0
Begin DoDot:1
+28 SET TIUDICDT=+$$IDATE^TIULC($GET(TIUDICDT))
+29 IF +TIUDICDT
IF ($PIECE(TIUDICDT,".",2)'>0)
Begin DoDot:2
+30 SET TIUDICDT=$SELECT($PIECE(TIU("VSTR"),";",3)'="H":$PIECE($GET(TIU("EDT")),U),1:"")
End DoDot:2
+31 SET TIURDT=$SELECT(+$GET(TIUDICDT)>0:+$GET(TIUDICDT),1:+$$NOW^TIULC)
+32 if +$GET(TIUTYPE)=1
SET @FDARR@(.12)=1
+33 KILL TIUDICDT
End DoDot:1
+34 IF '$GET(TIUPLDA)
SET @FDARR@(1301)=TIURDT
+35 SET @FDARR@(1303)="U"
+36 IF $GET(TIUPSC)]""
DO VAL^DIE(8925,DA,70201,,TIUPSC,.TIUPSCI)
+37 SET @FDARR@(70201)=$SELECT($GET(TIUPSCI):TIUPSCI,1:"")
+38 IF '$GET(TIUPLDA)!($PIECE($GET(^TIU(8925,+$GET(TIUPLDA),702)),U,2))=""
Begin DoDot:1
+39 IF $GET(TIUDTP)]""
DO VAL^DIE(8925,DA,70202,,TIUDTP,.TIUDTPI)
+40 SET @FDARR@(70202)=$SELECT($GET(TIUDTPI):TIUDTPI,1:"")
End DoDot:1
+41 DO FILE^DIE(FLAGS,"FDA","TIUMSG")
+42 QUIT
REQVER(VPARM) ; Evaluate whether verification is required
+1 QUIT $SELECT(VPARM=1:1,VPARM=2:1,1:0)
MAKEADD(TIUDADD,TIUDA,TIUBUF) ; Create an addendum record
+1 NEW DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUCAN,TIUFPRIV,TIU,TIUX
SET TIUFPRIV=1
+2 NEW TIUDTTL,TIUPOST,TIUREC
+3 SET TIUDTTL=+$GET(^TIU(8925,+TIUDA,0))
+4 SET TIUATYP=+$$WHATITLE^TIUPUTU("ADDENDUM")
+5 SET (DIC,DLAYGO)=8925
SET DIC(0)="L"
SET X=""""_"`"_TIUATYP_""""
+6 DO ^DIC
+7 SET TIUDADD=+Y
+8 IF +Y'>0
SET TIUDADD=TIUDADD_"^Could not create addendum."
QUIT
+9 DO GETTIU^TIULD(.TIU,TIUDA)
+10 SET TIU("DOCTYP")=TIUATYP_U_$$PNAME^TIULC1(TIUATYP)
+11 DO STUFREC(TIUDADD,DFN,+TIUDA,.TIU)
+12 DO LOADTIUX(.TIUX,TIUBUF)
+13 KILL ^TIU(8925,+TIUDADD,"TEMP")
+14 MERGE ^TIU(8925,+TIUDADD,"TEMP")=TIUX("TEXT")
KILL TIUX("TEXT")
+15 DO FILE(.SUCCESS,+TIUDADD,.TIUX,TIUATYP)
+16 DO MERGTEXT^TIUEDI1(+TIUDADD,.TIU)
+17 SET TIUPOST=$$POSTFILE^TIULC1(TIUDTTL)
+18 SET TIUREC("#")=TIUDADD
+19 IF TIUPOST]""
XECUTE TIUPOST
+20 KILL ^TIU(8925,+TIUDADD,"TEMP")
+21 QUIT
FILE(SUCCESS,TIUDA,TIUX,RTYPE) ; Call FM Filer to commit updates to DB
+1 NEW FDA,FDARR,IENS,FLAGS,TIUMSG
+2 SET IENS=""""_TIUDA_","""
SET FDARR="FDA(8925,"_IENS_")"
SET FLAGS="KE"
+3 MERGE @FDARR=TIUX
+4 ; File record
DO FILE^DIE(FLAGS,"FDA","TIUMSG")
+5 IF $DATA(TIUMSG)>9
Begin DoDot:1
+6 SET SUCCESS=0_U_$GET(TIUMSG("DIERR",1,"TEXT",1))
+7 DO MAIN^TIUPEVNT(TIUBUF,2,"",$PIECE($GET(^TIU(8925.1,+RTYPE,0)),U),.FDA,.TIUMSG)
End DoDot:1
+8 IF '$TEST
SET SUCCESS=TIUDA
+9 QUIT
TRNSFRM(RTYPE,FLD,X) ; Executes Transform code for a given header field
+1 NEW XFORM
+2 SET FLD=$ORDER(^TIU(8925.1,+RTYPE,"HEAD","D",+FLD,0))
+3 IF +FLD'>0
GOTO TRNSFRMX
+4 SET XFORM=$GET(^TIU(8925.1,+RTYPE,"HEAD",+FLD,1))
+5 IF XFORM']""
GOTO TRNSFRMX
+6 XECUTE XFORM
TRNSFRMX QUIT X
