- TIUSRVP1 ; SLC/JER - More API's in support of PUT ;11-Sep-2012 13:00;DU
- ;;1.0;TEXT INTEGRATION UTILITIES;**19,59,89,100,109,167,113,112,1009,219,1010**;Jun 20, 1997;Build 24
- ;Updated for event type
- SITEPARM(TIUY) ; Get site parameters for GUI
- N TIUPRM0,TIUPRM1
- D SETPARM^TIULE
- S TIUY=TIUPRM0
- Q
- DEFDOC(TIUY,HLOC,USER,TIUDT,TIUIEN) ; Get default primary provider
- N TIUSPRM,TIUDDOC,TIUAUTH
- D SITEPARM(.TIUSPRM)
- S TIUDDOC=+$P(TIUSPRM,U,8)
- S TIUAUTH=$S((+$G(USER)!('+$G(TIUIEN))):0,1:+$P($G(^TIU(8925,+$G(TIUIEN),12)),U,2))
- S USER=$S(+$G(USER):+$G(USER),+$G(TIUAUTH):+$G(TIUAUTH),1:DUZ)
- S TIUDT=$S(+$G(TIUDT):+$G(TIUDT),1:DT)
- S TIUY=$S(TIUDDOC=1:$$DFLTDOC^TIUPXAPI(HLOC),TIUDDOC=2:$$CURDOC(USER),1:"0^")
- Q
- CURDOC(USER,TIUDT) ; Is the current user a known Provider?
- N TIUY,TIUPROV S TIUY="0^"
- S USER=$S(+$G(USER):+$G(USER),1:DUZ)
- S TIUDT=$S(+$G(TIUDT):+$G(TIUDT),1:DT)
- S TIUPROV=$$PROVIDER^TIUPXAP1(USER,TIUDT)
- I +TIUPROV S TIUY=USER_U_$$PERSNAME^TIULC1(USER)
- Q TIUY
- ISAPROV(TIUY,USER,DATE) ; Is user a provider?
- ; Checks USR CLASS PROVIDER AND 200 Person Class
- ; DATE must not include time (for ISA^USRLM)
- S USER=$G(USER,DUZ)
- S DATE=$G(DATE,DT)
- S TIUY=$$PROVIDER^TIUPXAP1(USER,DATE)
- Q
- USRPROV(TIUY,USER,DATE) ; Is USER a USR CLASS provider?
- ; Checks USR CLASS PROVIDER only
- ; DATE must not include time
- N TIUERR
- S USER=$G(USER,DUZ)
- S DATE=$G(DATE,DT),TIUY=0
- I +$$ISA^USRLM(USER,"PROVIDER",.TIUERR,DATE) S TIUY=1 ; DBIA/ICR 2324
- Q
- DOCPARM(TIUY,TIUDA,TIUTYP) ; Get document parameters for GUI
- I '+$G(TIUTYP),+$G(TIUDA) S TIUTYP=+$G(^TIU(8925,+TIUDA,0))
- I '+$G(TIUTYP) S TIUY(0)="" Q
- D DOCPRM^TIULC1(TIUTYP,.TIUY,$G(TIUDA))
- I '$D(TIUY) S TIUY(0)=""
- Q
- CONSTUB(TIUDA,GMRCVP,DFN) ; Create a stub for a Consult Report
- N DIE,DR,DA
- D STUB(.TIUDA,"CONSULT REPORT",DFN)
- I +TIUDA'>0 Q
- S DIE=8925,DA=+TIUDA,DR="1405////^S X=GMRCVP"
- D ^DIE
- Q
- STUB(TIUDA,TIUTITL,DFN) ; Create a stub
- N TIUVSIT,TIUFPRIV,DIC,DIE,DR,DA,DLAYGO,X,Y S TIUFPRIV=1
- I +$G(TIUTITL)'>0 S TIUTITL=$$WHATITLE^TIUPUTU(TIUTITL)
- I +TIUTITL'>0 S TIUDA=-1 Q
- S (DIC,DLAYGO)=8925,DIC(0)="LF"
- S X=""""_"`"_+TIUTITL_""""
- D ^DIC S TIUDA=+Y Q:+Y'>0
- D EVENT(.TIU,DFN) I $L($G(TIU("VSTR")))'>0 S TIUDA=-1 Q
- S DIE=DIC,DA=TIUDA
- S DR=".02////"_+DFN_";.03////"_$P($G(TIU("VISIT")),U)_";.04////"_+$$DOCCLASS^TIULC1(TIUTITL)_";.05///UNDICTATED;.13////E;1301////"_+$$NOW^XLFDT
- D ^DIE
- Q
- EVENT(TIUY,DFN) ; Create an Event-type Visit Entry
- ;IHS/MSC/MGH This call was modified to use the IHS visit
- ;creation for a historical entry Patch 1009
- ;N VDT,VSTR,DGPM
- N DGPM,VIEN
- S DGPM=$G(^DPT(DFN,.105)) ;DBIA/ICR 10035
- ;I +DGPM'>0 D
- ;. S VDT=$$NOW^XLFDT
- ;. S VSTR=";"_VDT_";"_"E"
- D PATVADPT^TIULV(.TIUY,+DFN,DGPM,$G(VSTR))
- S TIUY("LOC")=VLOC_U_$P($G(^SC(VLOC,0)),U,1)
- I $G(TIUY("LOC"))="",+DUZ D
- .N TIUPREF,IDX
- .S TIUPREF=$$PERSPRF^TIULE(DUZ)
- .S IDX=+$P(TIUPREF,U,2)
- .I IDX S TIUY("LOC")=IDX_U_$P($G(^SC(IDX,0)),U,1) ; DBIA/ICR 10040
- S VIEN=$$FNDVIS^BEHOENCX(DFN,VDT,"E",VLOC,-1,,"")
- I +VIEN S TIU("VISIT")=VIEN
- Q
- GETPNAME(TIUY,TIUTYPE) ; Get Print Name of a Document
- S TIUY=$$PNAME^TIULC1(TIUTYPE)
- Q
- SAVED(TIUY,TIUDA) ; Was the document committed to the database?
- N TIUD12,TIUD13,TIUEBY,TIUAUT,TIUECS S TIUY=1
- S TIUD12=$G(^TIU(8925,TIUDA,12)),TIUD13=$G(^(13))
- S TIUEBY=$P(TIUD13,U,2),TIUAUT=$P(TIUD12,U,2),TIUECS=$P(TIUD12,U,8)
- I $D(^TIU(8925,"ASAVE",+DUZ,TIUDA)) D Q
- . S TIUY="0^You appear to have been disconnected..."
- I DUZ'=TIUEBY,(TIUEBY'=TIUAUT),$D(^TIU(8925,"ASAVE",+TIUEBY,TIUDA)) D Q
- . S TIUY="0^The transcriber appears to have been disconnected..."
- I DUZ'=TIUAUT,$D(^TIU(8925,"ASAVE",+TIUAUT,TIUDA)) D Q
- . S TIUY="0^The author appears to have been disconnected..."
- I DUZ'=TIUECS,$D(^TIU(8925,"ASAVE",+TIUECS,TIUDA)) D Q
- . S TIUY="0^The expected cosigner appears to have been disconnected..."
- Q
- STUFREC(TIUDA,TIUREC,DFN,PARENT,TITLE,TIU) ; load TIUREC for create
- N TIUREQCS,TIUSCAT,TIUSTAT,TIUCPF
- ;Set a flag to indicate whether or not a Title is a member of the
- ;Clinical Procedures Class (1=Yes and 0=No)
- S TIUCPF=+$$ISA^TIULX(TITLE,+$$CLASS^TIUCP)
- S TIUSTAT=$$STATUS(TIUDA,+$G(SUPPRESS),$G(TITLE))
- D REQCOS^TIUSRVA(.TIUREQCS,+TITLE,"",$S(+$G(TIUREC(1202)):+$G(TIUREC(1202)),1:DUZ))
- I +$G(PARENT)'>0 D
- . S TIUREC(.02)=$G(DFN),TIUREC(.03)=$P($G(TIU("VISIT")),U)
- . S TIUREC(.05)=$S(+$G(TIUREC(.05)):+$G(TIUREC(.05)),+TIUSTAT:TIUSTAT,1:5)
- . S TIUREC(.07)=$P($G(TIU("EDT")),U),TIUREC(.08)=$P($G(TIU("LDT")),U)
- . S TIUREC(1401)=$P($G(TIU("AD#")),U)
- . S TIUREC(1402)=$P($G(TIU("TS")),U)
- . S TIUREC(1404)=$P($G(TIU("SVC")),U)
- I +$G(PARENT)>0 D
- . S TIUREC(.02)=+$P($G(^TIU(8925,+PARENT,0)),U,2)
- . S TIUREC(.03)=+$P($G(^TIU(8925,+PARENT,0)),U,3)
- . S TIUREC(.05)=$S(+$G(TIUREC(.05)):+$G(TIUREC(.05)),+TIUSTAT:TIUSTAT,1:5)
- . S TIUREC(.06)=PARENT,TIUREC(.07)=$P(TIU("EDT"),U)
- . S TIUREC(.08)=$P(TIU("LDT"),U)
- . S TIUREC(1401)=$P($G(^TIU(8925,+PARENT,14)),U)
- . S TIUREC(1402)=$P($G(^TIU(8925,+PARENT,14)),U,2)
- . S TIUREC(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4)
- . S TIUREC(1405)=$P($G(^TIU(8925,+PARENT,14)),U,5)
- S TIUREC(.04)=$$DOCCLASS^TIULC1(TITLE)
- S TIUSCAT=$S(+$L($P($G(TIU("CAT")),U)):$P($G(TIU("CAT")),U),+$L($P($G(TIU("VSTR")),";",3)):$P($G(TIU("VSTR")),";",3),1:"")
- S TIUREC(.13)=TIUSCAT
- ;If the document is a member of the Clinical Procedures Class, set the
- ;Author/Dictator and the Expected Signer fields to Null
- S (TIUREC(1202),TIUREC(1204))=$S(+$G(TIUREC(1202)):+$G(TIUREC(1202)),TIUCPF:"",1:+$G(DUZ))
- S TIUREC(1212)=$P($G(TIU("INST")),U)
- S TIUREC(1205)=$P($G(TIU("LOC")),U)
- S TIUREC(1211)=$P($G(TIU("VLOC")),U)
- S TIUREC(1201)=$$NOW^XLFDT
- S TIUREC(1301)=$S($G(TIUREC(1301))]"":$P(TIUREC(1301),U),1:$$NOW^XLFDT)
- I +$$ISDS^TIULX(TITLE) D
- . I +$G(TIU("LDT"))'>0 S TIUREC(.12)=1
- . S TIUREC(.13)="H"
- . D REFDT(.TIUREC)
- ;If the document is a member of the Clinical Procedures Class, set the
- ;Entered By field to Null
- S TIUREC(1303)="R",TIUREC(1302)=$S(TIUCPF:"",1:$G(DUZ))
- I $S(+$G(TIUREC(1208))&(+$G(TIUREC(1204))'=+$G(TIUREC(1208))):1,+$G(TIUREQCS):1,1:0) S TIUREC(1506)=1
- Q
- REFDT(TIUX) ; Hack Ref Date/time for DS's
- S TIUX(1301)=$S(+$G(TIU("LDT")):+$G(TIU("LDT")),1:$G(TIUX(1301)))
- Q
- STATUS(TIUDA,SUPPRESS,TITLE) ; Compute the status of the current record
- N TIUDPRM,TIUY
- ; If the document is an addendum, compute status based on processing
- ; requirements of the Parent document or its ancestors
- I +$$ISADDNDM^TIULC1(TIUDA) D
- . S TIUDA=$S(+$P(^TIU(8925,TIUDA,0),U,6):$P(^(0),U,6),1:TIUDA)
- . S TITLE=+$G(^TIU(8925,TIUDA,0))
- D DOCPRM^TIULC1(TITLE,.TIUDPRM,$G(TIUDA))
- I +$P(TIUDPRM(0),U,2),+$G(SUPPRESS) S TIUY=3 G STATUX
- S TIUY=$S(+$$REQVER^TIULC(+TIUDA,+$P($G(TIUDPRM(0)),U,3)):4,1:5)
- STATUX Q TIUY
- IDATTCH(TIUY,TIUDA,TIUDAD) ; Attach TIUDA as ID Child entry to TIUDAD
- N TIUX
- S TIUX(2101)=TIUDAD
- D FILE^TIUSRVP(.TIUY,TIUDA,.TIUX,1)
- D AUDLINK^TIUGR1(TIUDA,"a",TIUDAD)
- D SENDID^TIUALRT1(TIUDA)
- Q
- IDDTCH(TIUY,TIUDA) ; Detach TIUDA from its ID Parent
- N TIUX,IDDAD
- I '+$G(^TIU(8925,TIUDA,21)) D Q
- . S TIUY="0^Record #"_TIUDA_" is NOT an ID Entry."
- S IDDAD=+$G(^TIU(8925,TIUDA,21))
- S TIUX(2101)="@"
- D FILE^TIUSRVP(.TIUY,TIUDA,.TIUX,1)
- D AUDLINK^TIUGR1(TIUDA,"d",IDDAD)
- D IDDEL^TIUALRT1(TIUDA)
- Q
- CANDEL(TIUDA) ; Boolean function to evaluate delete request
- Q $S($P(^TIU(8925,TIUDA,0),U,5)>3:0,'+$$EMPTYDOC^TIULF(TIUDA):0,1:1)
- TIUSRVP1 ; SLC/JER - More API's in support of PUT ;11-Sep-2012 13:00;DU
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**19,59,89,100,109,167,113,112,1009,219,1010**;Jun 20, 1997;Build 24
- +2 ;Updated for event type
- SITEPARM(TIUY) ; Get site parameters for GUI
- +1 NEW TIUPRM0,TIUPRM1
- +2 DO SETPARM^TIULE
- +3 SET TIUY=TIUPRM0
- +4 QUIT
- DEFDOC(TIUY,HLOC,USER,TIUDT,TIUIEN) ; Get default primary provider
- +1 NEW TIUSPRM,TIUDDOC,TIUAUTH
- +2 DO SITEPARM(.TIUSPRM)
- +3 SET TIUDDOC=+$PIECE(TIUSPRM,U,8)
- +4 SET TIUAUTH=$SELECT((+$GET(USER)!('+$GET(TIUIEN))):0,1:+$PIECE($GET(^TIU(8925,+$GET(TIUIEN),12)),U,2))
- +5 SET USER=$SELECT(+$GET(USER):+$GET(USER),+$GET(TIUAUTH):+$GET(TIUAUTH),1:DUZ)
- +6 SET TIUDT=$SELECT(+$GET(TIUDT):+$GET(TIUDT),1:DT)
- +7 SET TIUY=$SELECT(TIUDDOC=1:$$DFLTDOC^TIUPXAPI(HLOC),TIUDDOC=2:$$CURDOC(USER),1:"0^")
- +8 QUIT
- CURDOC(USER,TIUDT) ; Is the current user a known Provider?
- +1 NEW TIUY,TIUPROV
- SET TIUY="0^"
- +2 SET USER=$SELECT(+$GET(USER):+$GET(USER),1:DUZ)
- +3 SET TIUDT=$SELECT(+$GET(TIUDT):+$GET(TIUDT),1:DT)
- +4 SET TIUPROV=$$PROVIDER^TIUPXAP1(USER,TIUDT)
- +5 IF +TIUPROV
- SET TIUY=USER_U_$$PERSNAME^TIULC1(USER)
- +6 QUIT TIUY
- ISAPROV(TIUY,USER,DATE) ; Is user a provider?
- +1 ; Checks USR CLASS PROVIDER AND 200 Person Class
- +2 ; DATE must not include time (for ISA^USRLM)
- +3 SET USER=$GET(USER,DUZ)
- +4 SET DATE=$GET(DATE,DT)
- +5 SET TIUY=$$PROVIDER^TIUPXAP1(USER,DATE)
- +6 QUIT
- USRPROV(TIUY,USER,DATE) ; Is USER a USR CLASS provider?
- +1 ; Checks USR CLASS PROVIDER only
- +2 ; DATE must not include time
- +3 NEW TIUERR
- +4 SET USER=$GET(USER,DUZ)
- +5 SET DATE=$GET(DATE,DT)
- SET TIUY=0
- +6 ; DBIA/ICR 2324
- IF +$$ISA^USRLM(USER,"PROVIDER",.TIUERR,DATE)
- SET TIUY=1
- +7 QUIT
- DOCPARM(TIUY,TIUDA,TIUTYP) ; Get document parameters for GUI
- +1 IF '+$GET(TIUTYP)
- IF +$GET(TIUDA)
- SET TIUTYP=+$GET(^TIU(8925,+TIUDA,0))
- +2 IF '+$GET(TIUTYP)
- SET TIUY(0)=""
- QUIT
- +3 DO DOCPRM^TIULC1(TIUTYP,.TIUY,$GET(TIUDA))
- +4 IF '$DATA(TIUY)
- SET TIUY(0)=""
- +5 QUIT
- CONSTUB(TIUDA,GMRCVP,DFN) ; Create a stub for a Consult Report
- +1 NEW DIE,DR,DA
- +2 DO STUB(.TIUDA,"CONSULT REPORT",DFN)
- +3 IF +TIUDA'>0
- QUIT
- +4 SET DIE=8925
- SET DA=+TIUDA
- SET DR="1405////^S X=GMRCVP"
- +5 DO ^DIE
- +6 QUIT
- STUB(TIUDA,TIUTITL,DFN) ; Create a stub
- +1 NEW TIUVSIT,TIUFPRIV,DIC,DIE,DR,DA,DLAYGO,X,Y
- SET TIUFPRIV=1
- +2 IF +$GET(TIUTITL)'>0
- SET TIUTITL=$$WHATITLE^TIUPUTU(TIUTITL)
- +3 IF +TIUTITL'>0
- SET TIUDA=-1
- QUIT
- +4 SET (DIC,DLAYGO)=8925
- SET DIC(0)="LF"
- +5 SET X=""""_"`"_+TIUTITL_""""
- +6 DO ^DIC
- SET TIUDA=+Y
- IF +Y'>0
- QUIT
- +7 DO EVENT(.TIU,DFN)
- IF $LENGTH($GET(TIU("VSTR")))'>0
- SET TIUDA=-1
- QUIT
- +8 SET DIE=DIC
- SET DA=TIUDA
- +9 SET DR=".02////"_+DFN_";.03////"_$PIECE($GET(TIU("VISIT")),U)_";.04////"_+$$DOCCLASS^TIULC1(TIUTITL)_";.05///UNDICTATED;.13////E;1301////"_+$$NOW^XLFDT
- +10 DO ^DIE
- +11 QUIT
- EVENT(TIUY,DFN) ; Create an Event-type Visit Entry
- +1 ;IHS/MSC/MGH This call was modified to use the IHS visit
- +2 ;creation for a historical entry Patch 1009
- +3 ;N VDT,VSTR,DGPM
- +4 NEW DGPM,VIEN
- +5 ;DBIA/ICR 10035
- SET DGPM=$GET(^DPT(DFN,.105))
- +6 ;I +DGPM'>0 D
- +7 ;. S VDT=$$NOW^XLFDT
- +8 ;. S VSTR=";"_VDT_";"_"E"
- +9 DO PATVADPT^TIULV(.TIUY,+DFN,DGPM,$GET(VSTR))
- +10 SET TIUY("LOC")=VLOC_U_$PIECE($GET(^SC(VLOC,0)),U,1)
- +11 IF $GET(TIUY("LOC"))=""
- IF +DUZ
- Begin DoDot:1
- +12 NEW TIUPREF,IDX
- +13 SET TIUPREF=$$PERSPRF^TIULE(DUZ)
- +14 SET IDX=+$PIECE(TIUPREF,U,2)
- +15 ; DBIA/ICR 10040
- IF IDX
- SET TIUY("LOC")=IDX_U_$PIECE($GET(^SC(IDX,0)),U,1)
- End DoDot:1
- +16 SET VIEN=$$FNDVIS^BEHOENCX(DFN,VDT,"E",VLOC,-1,,"")
- +17 IF +VIEN
- SET TIU("VISIT")=VIEN
- +18 QUIT
- GETPNAME(TIUY,TIUTYPE) ; Get Print Name of a Document
- +1 SET TIUY=$$PNAME^TIULC1(TIUTYPE)
- +2 QUIT
- SAVED(TIUY,TIUDA) ; Was the document committed to the database?
- +1 NEW TIUD12,TIUD13,TIUEBY,TIUAUT,TIUECS
- SET TIUY=1
- +2 SET TIUD12=$GET(^TIU(8925,TIUDA,12))
- SET TIUD13=$GET(^(13))
- +3 SET TIUEBY=$PIECE(TIUD13,U,2)
- SET TIUAUT=$PIECE(TIUD12,U,2)
- SET TIUECS=$PIECE(TIUD12,U,8)
- +4 IF $DATA(^TIU(8925,"ASAVE",+DUZ,TIUDA))
- Begin DoDot:1
- +5 SET TIUY="0^You appear to have been disconnected..."
- End DoDot:1
- QUIT
- +6 IF DUZ'=TIUEBY
- IF (TIUEBY'=TIUAUT)
- IF $DATA(^TIU(8925,"ASAVE",+TIUEBY,TIUDA))
- Begin DoDot:1
- +7 SET TIUY="0^The transcriber appears to have been disconnected..."
- End DoDot:1
- QUIT
- +8 IF DUZ'=TIUAUT
- IF $DATA(^TIU(8925,"ASAVE",+TIUAUT,TIUDA))
- Begin DoDot:1
- +9 SET TIUY="0^The author appears to have been disconnected..."
- End DoDot:1
- QUIT
- +10 IF DUZ'=TIUECS
- IF $DATA(^TIU(8925,"ASAVE",+TIUECS,TIUDA))
- Begin DoDot:1
- +11 SET TIUY="0^The expected cosigner appears to have been disconnected..."
- End DoDot:1
- QUIT
- +12 QUIT
- STUFREC(TIUDA,TIUREC,DFN,PARENT,TITLE,TIU) ; load TIUREC for create
- +1 NEW TIUREQCS,TIUSCAT,TIUSTAT,TIUCPF
- +2 ;Set a flag to indicate whether or not a Title is a member of the
- +3 ;Clinical Procedures Class (1=Yes and 0=No)
- +4 SET TIUCPF=+$$ISA^TIULX(TITLE,+$$CLASS^TIUCP)
- +5 SET TIUSTAT=$$STATUS(TIUDA,+$GET(SUPPRESS),$GET(TITLE))
- +6 DO REQCOS^TIUSRVA(.TIUREQCS,+TITLE,"",$SELECT(+$GET(TIUREC(1202)):+$GET(TIUREC(1202)),1:DUZ))
- +7 IF +$GET(PARENT)'>0
- Begin DoDot:1
- +8 SET TIUREC(.02)=$GET(DFN)
- SET TIUREC(.03)=$PIECE($GET(TIU("VISIT")),U)
- +9 SET TIUREC(.05)=$SELECT(+$GET(TIUREC(.05)):+$GET(TIUREC(.05)),+TIUSTAT:TIUSTAT,1:5)
- +10 SET TIUREC(.07)=$PIECE($GET(TIU("EDT")),U)
- SET TIUREC(.08)=$PIECE($GET(TIU("LDT")),U)
- +11 SET TIUREC(1401)=$PIECE($GET(TIU("AD#")),U)
- +12 SET TIUREC(1402)=$PIECE($GET(TIU("TS")),U)
- +13 SET TIUREC(1404)=$PIECE($GET(TIU("SVC")),U)
- End DoDot:1
- +14 IF +$GET(PARENT)>0
- Begin DoDot:1
- +15 SET TIUREC(.02)=+$PIECE($GET(^TIU(8925,+PARENT,0)),U,2)
- +16 SET TIUREC(.03)=+$PIECE($GET(^TIU(8925,+PARENT,0)),U,3)
- +17 SET TIUREC(.05)=$SELECT(+$GET(TIUREC(.05)):+$GET(TIUREC(.05)),+TIUSTAT:TIUSTAT,1:5)
- +18 SET TIUREC(.06)=PARENT
- SET TIUREC(.07)=$PIECE(TIU("EDT"),U)
- +19 SET TIUREC(.08)=$PIECE(TIU("LDT"),U)
- +20 SET TIUREC(1401)=$PIECE($GET(^TIU(8925,+PARENT,14)),U)
- +21 SET TIUREC(1402)=$PIECE($GET(^TIU(8925,+PARENT,14)),U,2)
- +22 SET TIUREC(1404)=$PIECE($GET(^TIU(8925,+PARENT,14)),U,4)
- +23 SET TIUREC(1405)=$PIECE($GET(^TIU(8925,+PARENT,14)),U,5)
- End DoDot:1
- +24 SET TIUREC(.04)=$$DOCCLASS^TIULC1(TITLE)
- +25 SET TIUSCAT=$SELECT(+$LENGTH($PIECE($GET(TIU("CAT")),U)):$PIECE($GET(TIU("CAT")),U),+$LENGTH($PIECE($GET(TIU("VSTR")),";",3)):$PIECE($GET(TIU("VSTR")),";",3),1:"")
- +26 SET TIUREC(.13)=TIUSCAT
- +27 ;If the document is a member of the Clinical Procedures Class, set the
- +28 ;Author/Dictator and the Expected Signer fields to Null
- +29 SET (TIUREC(1202),TIUREC(1204))=$SELECT(+$GET(TIUREC(1202)):+$GET(TIUREC(1202)),TIUCPF:"",1:+$GET(DUZ))
- +30 SET TIUREC(1212)=$PIECE($GET(TIU("INST")),U)
- +31 SET TIUREC(1205)=$PIECE($GET(TIU("LOC")),U)
- +32 SET TIUREC(1211)=$PIECE($GET(TIU("VLOC")),U)
- +33 SET TIUREC(1201)=$$NOW^XLFDT
- +34 SET TIUREC(1301)=$SELECT($GET(TIUREC(1301))]"":$PIECE(TIUREC(1301),U),1:$$NOW^XLFDT)
- +35 IF +$$ISDS^TIULX(TITLE)
- Begin DoDot:1
- +36 IF +$GET(TIU("LDT"))'>0
- SET TIUREC(.12)=1
- +37 SET TIUREC(.13)="H"
- +38 DO REFDT(.TIUREC)
- End DoDot:1
- +39 ;If the document is a member of the Clinical Procedures Class, set the
- +40 ;Entered By field to Null
- +41 SET TIUREC(1303)="R"
- SET TIUREC(1302)=$SELECT(TIUCPF:"",1:$GET(DUZ))
- +42 IF $SELECT(+$GET(TIUREC(1208))&(+$GET(TIUREC(1204))'=+$GET(TIUREC(1208))):1,+$GET(TIUREQCS):1,1:0)
- SET TIUREC(1506)=1
- +43 QUIT
- REFDT(TIUX) ; Hack Ref Date/time for DS's
- +1 SET TIUX(1301)=$SELECT(+$GET(TIU("LDT")):+$GET(TIU("LDT")),1:$GET(TIUX(1301)))
- +2 QUIT
- STATUS(TIUDA,SUPPRESS,TITLE) ; Compute the status of the current record
- +1 NEW TIUDPRM,TIUY
- +2 ; If the document is an addendum, compute status based on processing
- +3 ; requirements of the Parent document or its ancestors
- +4 IF +$$ISADDNDM^TIULC1(TIUDA)
- Begin DoDot:1
- +5 SET TIUDA=$SELECT(+$PIECE(^TIU(8925,TIUDA,0),U,6):$PIECE(^(0),U,6),1:TIUDA)
- +6 SET TITLE=+$GET(^TIU(8925,TIUDA,0))
- End DoDot:1
- +7 DO DOCPRM^TIULC1(TITLE,.TIUDPRM,$GET(TIUDA))
- +8 IF +$PIECE(TIUDPRM(0),U,2)
- IF +$GET(SUPPRESS)
- SET TIUY=3
- GOTO STATUX
- +9 SET TIUY=$SELECT(+$$REQVER^TIULC(+TIUDA,+$PIECE($GET(TIUDPRM(0)),U,3)):4,1:5)
- STATUX QUIT TIUY
- IDATTCH(TIUY,TIUDA,TIUDAD) ; Attach TIUDA as ID Child entry to TIUDAD
- +1 NEW TIUX
- +2 SET TIUX(2101)=TIUDAD
- +3 DO FILE^TIUSRVP(.TIUY,TIUDA,.TIUX,1)
- +4 DO AUDLINK^TIUGR1(TIUDA,"a",TIUDAD)
- +5 DO SENDID^TIUALRT1(TIUDA)
- +6 QUIT
- IDDTCH(TIUY,TIUDA) ; Detach TIUDA from its ID Parent
- +1 NEW TIUX,IDDAD
- +2 IF '+$GET(^TIU(8925,TIUDA,21))
- Begin DoDot:1
- +3 SET TIUY="0^Record #"_TIUDA_" is NOT an ID Entry."
- End DoDot:1
- QUIT
- +4 SET IDDAD=+$GET(^TIU(8925,TIUDA,21))
- +5 SET TIUX(2101)="@"
- +6 DO FILE^TIUSRVP(.TIUY,TIUDA,.TIUX,1)
- +7 DO AUDLINK^TIUGR1(TIUDA,"d",IDDAD)
- +8 DO IDDEL^TIUALRT1(TIUDA)
- +9 QUIT
- CANDEL(TIUDA) ; Boolean function to evaluate delete request
- +1 QUIT $SELECT($PIECE(^TIU(8925,TIUDA,0),U,5)>3:0,'+$$EMPTYDOC^TIULF(TIUDA):0,1:1)