- TIUPEFIX ; SLC/JER - Resolve Filing errors for TIU Documents ;11/01/03
- ;;1.0;TEXT INTEGRATION UTILITIES;**1,21,100,167,113,112**;Jun 20, 1997
- 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")
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPEFIX 7297 printed Feb 19, 2025@00:09:36 Page 2
- TIUPEFIX ; SLC/JER - Resolve Filing errors for TIU Documents ;11/01/03
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**1,21,100,167,113,112**;Jun 20, 1997
- 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 DO EN^VALM("TIU BROWSE FOR MRT")
- End DoDot:1
- +7 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