- 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
- 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
