TIUPEFIX ; SLC/JER - Resolve Filing errors for TIU Documents ;01-Aug-2011 12:03;MGH
;;1.0;TEXT INTEGRATION UTILITIES;**1,21,100,167,113,112,1007,1009**;Jun 20, 1997;Build 22
;IHSITSC/LJF 02/26/2004 change call to IHS list template
MAKE(SUCCESS,DFN,TITLE,TIU,TIUBUF) ; 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)
;
; -- first, get TIU Document record --
;
N TIUDA,LDT,NEWREC,TIUX,TIUTYP,TIUDPRM,HAPPY,TIUCLASS,TIUDTYP,TIUPOST
N TIUDFLT,TIUREC
S SUCCESS=0 ; Initialize SUCCESS to false
I $S($D(TIU)'>9:1,+$G(DFN)'>0:1,+$G(TIUTYPE)'>0:1,1:0) S SUCCESS="0^"_$$EZBLD^DIALOG(89250001) Q
; If target file is not 8925 QUIT
I +$G(^TIU(8925.1,+TIUTYPE,1))'=8925 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)
Q:+TITLE'>0
S TIUTYP=TITLE,TIUTYP(1)=1_U_TITLE
D DOCPRM^TIULC1(TITLE,.TIUDPRM)
;S TIUDA=$$GETREC^TIUEDI1(DFN,.TIU,1,.NEWREC,.TIUDPRM) ;10/27/00
S TIUDA=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.NEWREC,.TIUDPRM)
I +TIUDA'>0 S SUCCESS="0^"_$$EZBLD^DIALOG(89250002) Q
I +$$CANEDIT^TIUPUTU(TIUDA)'>0 D G MAKEX
. D MAKEADD(.TIUADD,+TIUDA,TIUBUF) S SUCCESS=TIUADD
S SUCCESS=1
;
; -- second, load the header elements & text into TIUX array
;
D STUFREC(TIUDA,$G(DFN),$P($G(^TIU(8925,TIUDA,0)),U,6),.TIU)
D LOADTIUX(.TIUX,TIUBUF)
;
; -- 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)
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") ;IHS/ITSC/LJF 02/06/2003
. D EN^VALM("BTIU BROWSE FOR HIS") ;IHS/ITSC/LJF 02/26/2003
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) ; Stuff fixed field data
N FDA,FDARR,IENS,FLAGS,TIUMSG,TIURDT
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)=$S(+$$REQVER(+$P($G(TIUDPRM(0)),U,3)):4,1:5)
. S @FDARR@(.07)=$P(TIU("EDT"),U)
. S @FDARR@(.08)=$P(TIU("LDT"),U),@FDARR@(1401)=$P($G(TIU("AD#")),U)
. S @FDARR@(1402)=$P($G(TIU("TS")),U),@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)
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) ; if parent's div null so is addendum's div
. 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@(1405)=$P($G(^TIU(8925,+PARENT,14)),U,5)
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
S @FDARR@(1301)=TIURDT,@FDARR@(1303)="U"
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"),TIUX(.001),TIUX(1405)
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
TIUPEFIX ; SLC/JER - Resolve Filing errors for TIU Documents ;01-Aug-2011 12:03;MGH
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1,21,100,167,113,112,1007,1009**;Jun 20, 1997;Build 22
+2 ;IHSITSC/LJF 02/26/2004 change call to IHS list template
MAKE(SUCCESS,DFN,TITLE,TIU,TIUBUF) ; 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 ;
+8 ; -- first, get TIU Document record --
+9 ;
+10 NEW TIUDA,LDT,NEWREC,TIUX,TIUTYP,TIUDPRM,HAPPY,TIUCLASS,TIUDTYP,TIUPOST
+11 NEW TIUDFLT,TIUREC
+12 ; Initialize SUCCESS to false
SET SUCCESS=0
+13 IF $SELECT($DATA(TIU)'>9:1,+$GET(DFN)'>0:1,+$GET(TIUTYPE)'>0:1,1:0)
SET SUCCESS="0^"_$$EZBLD^DIALOG(89250001)
QUIT
+14 ; If target file is not 8925 QUIT
+15 IF +$GET(^TIU(8925.1,+TIUTYPE,1))'=8925
QUIT
+16 SET TIUDTYP=$PIECE($GET(^TIU(8925.1,+TIUTYPE,0)),U,4)
+17 SET TIUCLASS=$SELECT(TIUDTYP="CL":+TIUTYPE,1:38)
+18 SET TIUDFLT=$SELECT(TIUCLASS'=TIUTYPE:TIUTYPE,1:"")
+19 IF +$GET(TITLE)'>0
SET TITLE=$$ASKTITLE^TIULA3(TIUCLASS,TIUDFLT)
+20 IF +TITLE'>0
QUIT
+21 SET TIUTYP=TITLE
SET TIUTYP(1)=1_U_TITLE
+22 DO DOCPRM^TIULC1(TITLE,.TIUDPRM)
+23 ;S TIUDA=$$GETREC^TIUEDI1(DFN,.TIU,1,.NEWREC,.TIUDPRM) ;10/27/00
+24 SET TIUDA=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.NEWREC,.TIUDPRM)
+25 IF +TIUDA'>0
SET SUCCESS="0^"_$$EZBLD^DIALOG(89250002)
QUIT
+26 IF +$$CANEDIT^TIUPUTU(TIUDA)'>0
Begin DoDot:1
+27 DO MAKEADD(.TIUADD,+TIUDA,TIUBUF)
SET SUCCESS=TIUADD
End DoDot:1
GOTO MAKEX
+28 SET SUCCESS=1
+29 ;
+30 ; -- second, load the header elements & text into TIUX array
+31 ;
+32 DO STUFREC(TIUDA,$GET(DFN),$PIECE($GET(^TIU(8925,TIUDA,0)),U,6),.TIU)
+33 DO LOADTIUX(.TIUX,TIUBUF)
+34 ;
+35 ; -- third, file the data in TIU Document record --
+36 ;
+37 KILL ^TIU(8925,+TIUDA,"TEMP"),TIUX(.01),TIUX(.02),TIUX(.03),TIUX(.05)
+38 KILL TIUX(.13),TIUX(1205),TIUX(1211)
+39 MERGE ^TIU(8925,+TIUDA,"TEMP")=TIUX("TEXT")
KILL TIUX("TEXT")
+40 DO FILE(.HAPPY,+TIUDA,.TIUX,TIUTYP)
+41 DO MERGTEXT^TIUEDI1(+TIUDA,.TIU)
+42 SET TIUPOST=$$POSTFILE^TIULC1(TITLE)
+43 SET TIUREC("#")=TIUDA
+44 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 ;D EN^VALM("TIU BROWSE FOR MRT") ;IHS/ITSC/LJF 02/06/2003
+7 ;IHS/ITSC/LJF 02/26/2003
DO EN^VALM("BTIU BROWSE FOR HIS")
End DoDot:1
+8 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) ; Stuff fixed field data
+1 NEW FDA,FDARR,IENS,FLAGS,TIUMSG,TIURDT
+2 SET IENS=""""_DA_","""
SET FDARR="FDA(8925,"_IENS_")"
SET FLAGS="K"
+3 IF +$GET(PARENT)'>0
Begin DoDot:1
+4 SET @FDARR@(.02)=$GET(DFN)
SET @FDARR@(.03)=$PIECE($GET(TIU("VISIT")),U)
+5 SET @FDARR@(.05)=$SELECT(+$$REQVER(+$PIECE($GET(TIUDPRM(0)),U,3)):4,1:5)
+6 SET @FDARR@(.07)=$PIECE(TIU("EDT"),U)
+7 SET @FDARR@(.08)=$PIECE(TIU("LDT"),U)
SET @FDARR@(1401)=$PIECE($GET(TIU("AD#")),U)
+8 SET @FDARR@(1402)=$PIECE($GET(TIU("TS")),U)
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:1
+12 IF +$GET(PARENT)>0
Begin DoDot:1
+13 SET @FDARR@(.02)=+$PIECE(^TIU(8925,+PARENT,0),U,2)
+14 SET @FDARR@(.03)=$PIECE(^TIU(8925,+PARENT,0),U,3)
+15 SET @FDARR@(.05)=$SELECT(+$$REQVER(+$PIECE($GET(TIUDPRM(0)),U,3)):4,1:5)
+16 SET @FDARR@(.06)=PARENT
+17 SET @FDARR@(.07)=$PIECE($GET(TIU("EDT")),U)
SET @FDARR@(.08)=$PIECE($GET(TIU("LDT")),U)
+18 SET @FDARR@(1205)=$PIECE($GET(^TIU(8925,+PARENT,12)),U,5)
+19 ; if parent's div null so is addendum's div
SET @FDARR@(1212)=$PIECE($GET(^TIU(8925,+PARENT,12)),U,12)
+20 SET @FDARR@(1401)=$PIECE($GET(^TIU(8925,+PARENT,14)),U)
+21 SET @FDARR@(1402)=$PIECE($GET(^TIU(8925,+PARENT,14)),U,2)
+22 SET @FDARR@(1404)=$PIECE($GET(^TIU(8925,+PARENT,14)),U,4)
+23 SET @FDARR@(1405)=$PIECE($GET(^TIU(8925,+PARENT,14)),U,5)
End DoDot:1
+24 SET @FDARR@(1201)=$$NOW^XLFDT
+25 IF +$GET(TIU("LDT"))
SET TIURDT=+$GET(TIU("LDT"))
+26 IF +$GET(TIU("LDT"))'>0
Begin DoDot:1
+27 SET TIUDICDT=+$$IDATE^TIULC($GET(TIUDICDT))
+28 IF +TIUDICDT
IF ($PIECE(TIUDICDT,".",2)'>0)
Begin DoDot:2
+29 SET TIUDICDT=$SELECT($PIECE(TIU("VSTR"),";",3)'="H":$PIECE($GET(TIU("EDT")),U),1:"")
End DoDot:2
+30 SET TIURDT=$SELECT(+$GET(TIUDICDT)>0:+$GET(TIUDICDT),1:+$$NOW^TIULC)
+31 IF +$GET(TIUTYPE)=1
SET @FDARR@(.12)=1
+32 KILL TIUDICDT
End DoDot:1
+33 SET @FDARR@(1301)=TIURDT
SET @FDARR@(1303)="U"
+34 DO FILE^DIE(FLAGS,"FDA","TIUMSG")
+35 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"),TIUX(.001),TIUX(1405)
+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
