BEHODCP ;MSC/IND/MGH - TIU Progress Note Look-up Method ;20-Mar-2007 13:48;DKM
;;1.1;BEH COMPONENTS;**001001**;Mar 20, 2007
;=================================================================
;Functionally the same as TIUPUTPN except modified to use note IEN
;and not to use SSN for patient identifier.
;===============================================================
LOOKUP ; Look-up code used by router/filer
; Required: TIUHRN, TIUVDT
N DA,DFN,TIU,TIUDAD,TIUEDIT,TIUEDT,TIULDT,TIUXCRP,TIUTYPE,TIUNEW
N TIUDPRM,TIUIEN,BEHDFN,CREATE,BEHTIU,TIUNAME2,TIUVSTRB
IEN ;Get data needed to identify note
S BEHTIU=+$G(TIUHDR("TIUHRN")) S DFN=$$CKHRN(BEHTIU)
;I $S('$D(TIUNAME):1,'$D(TIUVDT):1,1:0) S Y=-1 G LOOKUPX
I DFN="" S Y=-1 G LOOKUPX
S TIUNAME2=$P($G(^DPT(DFN,0)),U,1)
S TIUSSN=$P($G(^DPT(DFN,0)),U,9)
; Check clinic name
I '$G(TIUHDR("TIUIEN")) D G:Y=-1 LOOKUPX
.I '$L($G(TIULOC)) S Y=-1 Q
.S TIULOC=+$$ILOC(TIULOC)
.I '$D(^SC(+$G(TIULOC),0)) S Y=-1
; Check appointment date
I '$G(TIUHDR("TIUIEN")) D G:Y=-1 LOOKUPX
.S TIUEDT=$$IDATE(+$G(TIUVDT)),TIULDT=$$FMADD^XLFDT(TIUEDT,1)
.I +TIUEDT'>0 S Y=-1
S TIUTYPE=$$WHATITLE(TIUTITLE)
I +TIUTYPE'>0 S Y=-1 G LOOKUPX
D DOCPRM^TIULC1(+TIUTYPE,.TIUDPRM)
I $G(TIUHDR("TIUIEN"))="" D NAMECK,REGULAR:Y'=-1
I $G(TIUHDR("TIUIEN"))'="" D SPECIAL,REGULAR:Y'=-1
Q
; Returns patient for given HRN and DUZ(2) value
; Input - BEHTIU - Health Record Number
; Assumes - DUZ(2) is set to currently facility
; Returns - DFN or ""
CKHRN(BEHTIU) ;If entered name doesn't match a patient, use the Health
;Record Number if available.
N INST,DFN,RES
S BEHTIU=$G(BEHTIU,""),RES=""
I BEHTIU'="" D
.S DFN=0 F S DFN=$O(^AUPNPAT("D",BEHTIU,DFN)) Q:'DFN!RES D
..S INST=0 F S INST=$O(^AUPNPAT("D",BEHTIU,DFN,INST)) Q:'INST!RES D
...S:INST=DUZ(2) RES=DFN
Q RES
NAMECK ; If no note ien, check last name entered with last name from HRN
N LNAME1,LNAME2
S LNAME1=$P($G(TIUNAME),","),LNAME2=$P(TIUNAME2,",")
I LNAME1'=LNAME2 S Y=-1
Q
SPECIAL ;If the note ien exists, make sure its the correct one
S TIUIEN=$G(TIUHDR("TIUIEN"))
I $G(^TIU(8925,TIUIEN,0))="" S Y=-1 Q
I $P($G(^TIU(8925,TIUIEN,0)),U,2)'=DFN S TIUIEN="",Y=-1 Q
I $P($G(^TIU(8925,TIUIEN,0)),U,1)'=$P(TIUTYPE,U,1) S TIUIEN="",Y=-1 Q
S TIULOC=$P($G(^TIU(8925,TIUIEN,12)),U,5)
S TIUEDT=$P($G(^TIU(8925,TIUIEN,0)),U,7)
S TIULDT=$P($G(^TIU(8925,TIUIEN,0)),U,8)
S TIUVISIT=$P($G(^TIU(8925,TIUIEN,0)),U,3)
Q
REGULAR ;Get the visit
I $P($G(^SC(+$G(TIULOC),0)),U,3)="W" S TIUSC="H"
E S TIUSC="A"
S TIUVSTR=TIULOC_";"_TIUEDT_";"_TIUSC
;The variable TIUVSTR needs the fourth element (the IEN) if the
;visit is known. However, the TIU lookup routine does not use this
;element so both of them have to be saved
I $D(TIUIEN) S TIUVSTRB=TIUVSTR_";"_$G(TIUVISIT)
E S TIUVSTRB=TIUVSTR
S CREATE=1
;Find the visit or make a new one
S TIUVISIT=$$VSTR2VIS^BEHOENCX(DFN,TIUVSTRB,CREATE)
S TIUVSTR=$P(TIUVSTRB,";",1,3)
;Get the variables for the TIU array
D PATVADPT^TIULV(.TIU,DFN,"",TIUVSTR)
S TIUTYP(1)=1_U_TIUTYPE_U_$$PNAME^TIULC1(TIUTYPE)
;Store record
I +$G(TIUIEN) D
.S Y=TIUIEN
E S Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
I +Y'>0 G LOOKUPX
; If record is not new, has text and can be edited, then replace
; existing text
I +$G(TIUNEW)'>0 D
. S TIUEDIT=$$CANEDIT(+Y)
. I +TIUEDIT>0,$D(^TIU(8925,+Y,"TEXT")) D DELTEXT(+Y)
. I +TIUEDIT'>0 S TIUDAD=+Y,Y=$$MAKEADD
I +Y'>0 Q
D STUFREC(Y,+$G(TIUDAD))
I +$G(TIUDAD) D SENDADD^TIUALRT(+Y)
K TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
LOOKUPX Q
IDATE(X) ; Receives date in external format, returns internal format
N %DT,Y
I ($L(X," ")=2),(X?1.2N1P1.2N1P1.2N.2N1" "1.2N.E) S X=$TR(X," ","@")
S %DT="TSP" D ^%DT
Q Y
ILOC(LOCATION) ; Get pointer to file 44
N DIC,X,Y
S DIC=44,DIC(0)="M",X=LOCATION D ^DIC
Q Y
CANEDIT(DA) ; Check whether or not document is in a status up to unsigned
Q $S(+$P($G(^TIU(8925,+DA,0)),U,5)<6:1,1:0)
MAKEADD() ; Create an addendum record
N DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUFPRIV S TIUFPRIV=1
S TIUATYP=+$$WHATITLE("ADDENDUM")
S (DIC,DLAYGO)=8925,DIC(0)="L",X=""""_"`"_TIUATYP_""""
D ^DIC
S DA=+Y
I +DA>0 S DIE=DIC,DR=".04////"_$$DOCCLASS^TIULC1(TIUATYP) D ^DIE
K TIUHDR(.01)
Q +DA
STUFREC(DA,PARENT) ; Stuff fixed field data
N FDA,FDARR,IENS,FLAGS,TIUMSG
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)=3
. S @FDARR@(.07)=$P($G(TIU("EDT")),U)
. S @FDARR@(.08)=$P($G(TIU("LDT")),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@(1211)=$P($G(TIU("VLOC")),U)
. S @FDARR@(1404)=$P($G(TIU("SVC")),U)
I +$G(PARENT)>0 D
. S @FDARR@(.02)=+$P($G(^TIU(8925,+PARENT,0)),U,2)
. S @FDARR@(.03)=+$P($G(^TIU(8925,+PARENT,0)),U,3),@FDARR@(.05)=3
. S @FDARR@(.06)=PARENT
. S @FDARR@(.07)=$P($G(^TIU(8925,+PARENT,0)),U,7)
. S @FDARR@(.08)=$P($G(^TIU(8925,+PARENT,0)),U,8)
. S @FDARR@(1205)=$P($G(^TIU(8925,+PARENT,12)),U,5)
. S @FDARR@(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4)
. S @FDARR@(1201)=$$NOW^TIULC
S @FDARR@(1205)=$P($G(TIU("LOC")),U)
S @FDARR@(1301)=$S($G(TIUDDT)]"":$$IDATE^TIULC($G(TIUDDT)),1:"")
I $S(@FDARR@(1301)'>0:1,$P(@FDARR@(1301),".",2)']"":1,1:0) D
. S @FDARR@(1301)=$S($P($G(TIU("VSTR")),";",3)="H":$$NOW^XLFDT,1:$G(@FDARR@(.07)))
S @FDARR@(1303)="U"
D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
Q
DELTEXT(DA) ; Delete existing text in preparation for replacement
N DIE,DR,X,Y
S DIE=8925,DR="2///@" D ^DIE
Q
WHATYPE(X) ; Identify document type
; Receives: X=Document Definition Name
; Returns: Y=Document Definition IFN
N DIC,Y,TIUFPRIV S TIUFPRIV=1
S DIC=8925.1,DIC(0)="M"
S DIC("S")="I $D(^TIU(8925.1,+Y,""HEAD""))!$D(^TIU(8295.1,+Y,""ITEM""))"
D ^DIC K DIC("S")
WHATYPX Q Y
WHATITLE(X) ; Identify document title
; Receives: X=Document Definition Name
; Returns: Y=Document Definition IFN
N DIC,Y,TIUFPRIV S TIUFPRIV=1
S DIC=8925.1,DIC(0)="M"
S DIC("S")="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"""
D ^DIC K DIC("S")
WHATITX Q Y
FOLLOWUP(TIUDA) ; Post-filing code for PROGRESS NOTES
N FDA,FDARR,IENS,FLAGS,TIUMSG,TIU,DFN
S IENS=""""_TIUDA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
S @FDARR@(1204)=$$WHOSIGNS^TIULC1(TIUDA)
I +$P($G(^TIU(8925,TIUDA,12)),U,9),'+$P($G(^(12)),U,8) D
. S @FDARR@(1208)=$$WHOCOSIG^TIULC1(TIUDA)
D FILE^DIE(FLAGS,"FDA","TIUMSG")
I +$P($G(^TIU(8925,+TIUDA,12)),U,8),(+$P($G(^TIU(8925,+TIUDA,12)),U,4)'=+$P($G(^(12)),U,8)) D
. S @FDARR@(1506)=1 D FILE^DIE(FLAGS,"FDA","TIUMSG")
D RELEASE^TIUT(TIUDA,1)
D AUDIT^TIUEDI1(TIUDA,0,$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")"))
I '$D(TIU("VSTR")) D
. N TIUD0,TIUD12,TIUVLOC,TIUHLOC,TIUEDT,TIULDT
. S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^(12))
. S DFN=+$P(TIUD0,U,2),TIUEDT=+$P(TIUD0,U,7)
. S TIULDT=$$FMADD^XLFDT(TIUEDT,1),TIUHLOC=+$P(TIUD12,U,5)
. S TIUVLOC=$S(+$P(TIUD12,U,11):+$P(TIUD12,U,11),1:+TIUHLOC)
. I $S(+DFN'>0:1,+TIUEDT'>0:1,+TIULDT'>0:1,+TIUVLOC'>0:1,1:0) Q
. D MAIN^TIUVSIT(.TIU,DFN,"",TIUEDT,TIULDT,"LAST",0,+TIUVLOC)
Q:'$D(TIU("VSTR"))
D ENQ^TIUPXAP1 ; Get/file VISIT
Q
BEHODCP ;MSC/IND/MGH - TIU Progress Note Look-up Method ;20-Mar-2007 13:48;DKM
+1 ;;1.1;BEH COMPONENTS;**001001**;Mar 20, 2007
+2 ;=================================================================
+3 ;Functionally the same as TIUPUTPN except modified to use note IEN
+4 ;and not to use SSN for patient identifier.
+5 ;===============================================================
LOOKUP ; Look-up code used by router/filer
+1 ; Required: TIUHRN, TIUVDT
+2 NEW DA,DFN,TIU,TIUDAD,TIUEDIT,TIUEDT,TIULDT,TIUXCRP,TIUTYPE,TIUNEW
+3 NEW TIUDPRM,TIUIEN,BEHDFN,CREATE,BEHTIU,TIUNAME2,TIUVSTRB
IEN ;Get data needed to identify note
+1 SET BEHTIU=+$GET(TIUHDR("TIUHRN"))
SET DFN=$$CKHRN(BEHTIU)
+2 ;I $S('$D(TIUNAME):1,'$D(TIUVDT):1,1:0) S Y=-1 G LOOKUPX
+3 IF DFN=""
SET Y=-1
GOTO LOOKUPX
+4 SET TIUNAME2=$PIECE($GET(^DPT(DFN,0)),U,1)
+5 SET TIUSSN=$PIECE($GET(^DPT(DFN,0)),U,9)
+6 ; Check clinic name
+7 IF '$GET(TIUHDR("TIUIEN"))
Begin DoDot:1
+8 IF '$LENGTH($GET(TIULOC))
SET Y=-1
QUIT
+9 SET TIULOC=+$$ILOC(TIULOC)
+10 IF '$DATA(^SC(+$GET(TIULOC),0))
SET Y=-1
End DoDot:1
IF Y=-1
GOTO LOOKUPX
+11 ; Check appointment date
+12 IF '$GET(TIUHDR("TIUIEN"))
Begin DoDot:1
+13 SET TIUEDT=$$IDATE(+$GET(TIUVDT))
SET TIULDT=$$FMADD^XLFDT(TIUEDT,1)
+14 IF +TIUEDT'>0
SET Y=-1
End DoDot:1
IF Y=-1
GOTO LOOKUPX
+15 SET TIUTYPE=$$WHATITLE(TIUTITLE)
+16 IF +TIUTYPE'>0
SET Y=-1
GOTO LOOKUPX
+17 DO DOCPRM^TIULC1(+TIUTYPE,.TIUDPRM)
+18 IF $GET(TIUHDR("TIUIEN"))=""
DO NAMECK
IF Y'=-1
DO REGULAR
+19 IF $GET(TIUHDR("TIUIEN"))'=""
DO SPECIAL
IF Y'=-1
DO REGULAR
+20 QUIT
+21 ; Returns patient for given HRN and DUZ(2) value
+22 ; Input - BEHTIU - Health Record Number
+23 ; Assumes - DUZ(2) is set to currently facility
+24 ; Returns - DFN or ""
CKHRN(BEHTIU) ;If entered name doesn't match a patient, use the Health
+1 ;Record Number if available.
+2 NEW INST,DFN,RES
+3 SET BEHTIU=$GET(BEHTIU,"")
SET RES=""
+4 IF BEHTIU'=""
Begin DoDot:1
+5 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT("D",BEHTIU,DFN))
IF 'DFN!RES
QUIT
Begin DoDot:2
+6 SET INST=0
FOR
SET INST=$ORDER(^AUPNPAT("D",BEHTIU,DFN,INST))
IF 'INST!RES
QUIT
Begin DoDot:3
+7 IF INST=DUZ(2)
SET RES=DFN
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT RES
NAMECK ; If no note ien, check last name entered with last name from HRN
+1 NEW LNAME1,LNAME2
+2 SET LNAME1=$PIECE($GET(TIUNAME),",")
SET LNAME2=$PIECE(TIUNAME2,",")
+3 IF LNAME1'=LNAME2
SET Y=-1
+4 QUIT
SPECIAL ;If the note ien exists, make sure its the correct one
+1 SET TIUIEN=$GET(TIUHDR("TIUIEN"))
+2 IF $GET(^TIU(8925,TIUIEN,0))=""
SET Y=-1
QUIT
+3 IF $PIECE($GET(^TIU(8925,TIUIEN,0)),U,2)'=DFN
SET TIUIEN=""
SET Y=-1
QUIT
+4 IF $PIECE($GET(^TIU(8925,TIUIEN,0)),U,1)'=$PIECE(TIUTYPE,U,1)
SET TIUIEN=""
SET Y=-1
QUIT
+5 SET TIULOC=$PIECE($GET(^TIU(8925,TIUIEN,12)),U,5)
+6 SET TIUEDT=$PIECE($GET(^TIU(8925,TIUIEN,0)),U,7)
+7 SET TIULDT=$PIECE($GET(^TIU(8925,TIUIEN,0)),U,8)
+8 SET TIUVISIT=$PIECE($GET(^TIU(8925,TIUIEN,0)),U,3)
+9 QUIT
REGULAR ;Get the visit
+1 IF $PIECE($GET(^SC(+$GET(TIULOC),0)),U,3)="W"
SET TIUSC="H"
+2 IF '$TEST
SET TIUSC="A"
+3 SET TIUVSTR=TIULOC_";"_TIUEDT_";"_TIUSC
+4 ;The variable TIUVSTR needs the fourth element (the IEN) if the
+5 ;visit is known. However, the TIU lookup routine does not use this
+6 ;element so both of them have to be saved
+7 IF $DATA(TIUIEN)
SET TIUVSTRB=TIUVSTR_";"_$GET(TIUVISIT)
+8 IF '$TEST
SET TIUVSTRB=TIUVSTR
+9 SET CREATE=1
+10 ;Find the visit or make a new one
+11 SET TIUVISIT=$$VSTR2VIS^BEHOENCX(DFN,TIUVSTRB,CREATE)
+12 SET TIUVSTR=$PIECE(TIUVSTRB,";",1,3)
+13 ;Get the variables for the TIU array
+14 DO PATVADPT^TIULV(.TIU,DFN,"",TIUVSTR)
+15 SET TIUTYP(1)=1_U_TIUTYPE_U_$$PNAME^TIULC1(TIUTYPE)
+16 ;Store record
+17 IF +$GET(TIUIEN)
Begin DoDot:1
+18 SET Y=TIUIEN
End DoDot:1
+19 IF '$TEST
SET Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
+20 IF +Y'>0
GOTO LOOKUPX
+21 ; If record is not new, has text and can be edited, then replace
+22 ; existing text
+23 IF +$GET(TIUNEW)'>0
Begin DoDot:1
+24 SET TIUEDIT=$$CANEDIT(+Y)
+25 IF +TIUEDIT>0
IF $DATA(^TIU(8925,+Y,"TEXT"))
DO DELTEXT(+Y)
+26 IF +TIUEDIT'>0
SET TIUDAD=+Y
SET Y=$$MAKEADD
End DoDot:1
+27 IF +Y'>0
QUIT
+28 DO STUFREC(Y,+$GET(TIUDAD))
+29 IF +$GET(TIUDAD)
DO SENDADD^TIUALRT(+Y)
+30 KILL TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
LOOKUPX QUIT
IDATE(X) ; Receives date in external format, returns internal format
+1 NEW %DT,Y
+2 IF ($LENGTH(X," ")=2)
IF (X?1.2N1P1.2N1P1.2N.2N1" "1.2N.E)
SET X=$TRANSLATE(X," ","@")
+3 SET %DT="TSP"
DO ^%DT
+4 QUIT Y
ILOC(LOCATION) ; Get pointer to file 44
+1 NEW DIC,X,Y
+2 SET DIC=44
SET DIC(0)="M"
SET X=LOCATION
DO ^DIC
+3 QUIT Y
CANEDIT(DA) ; Check whether or not document is in a status up to unsigned
+1 QUIT $SELECT(+$PIECE($GET(^TIU(8925,+DA,0)),U,5)<6:1,1:0)
MAKEADD() ; Create an addendum record
+1 NEW DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUFPRIV
SET TIUFPRIV=1
+2 SET TIUATYP=+$$WHATITLE("ADDENDUM")
+3 SET (DIC,DLAYGO)=8925
SET DIC(0)="L"
SET X=""""_"`"_TIUATYP_""""
+4 DO ^DIC
+5 SET DA=+Y
+6 IF +DA>0
SET DIE=DIC
SET DR=".04////"_$$DOCCLASS^TIULC1(TIUATYP)
DO ^DIE
+7 KILL TIUHDR(.01)
+8 QUIT +DA
STUFREC(DA,PARENT) ; Stuff fixed field data
+1 NEW FDA,FDARR,IENS,FLAGS,TIUMSG
+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)=3
+6 SET @FDARR@(.07)=$PIECE($GET(TIU("EDT")),U)
+7 SET @FDARR@(.08)=$PIECE($GET(TIU("LDT")),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 ;S @FDARR@(1211)=$P($G(TIU("VLOC")),U)
+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($GET(^TIU(8925,+PARENT,0)),U,2)
+14 SET @FDARR@(.03)=+$PIECE($GET(^TIU(8925,+PARENT,0)),U,3)
SET @FDARR@(.05)=3
+15 SET @FDARR@(.06)=PARENT
+16 SET @FDARR@(.07)=$PIECE($GET(^TIU(8925,+PARENT,0)),U,7)
+17 SET @FDARR@(.08)=$PIECE($GET(^TIU(8925,+PARENT,0)),U,8)
+18 SET @FDARR@(1205)=$PIECE($GET(^TIU(8925,+PARENT,12)),U,5)
+19 SET @FDARR@(1404)=$PIECE($GET(^TIU(8925,+PARENT,14)),U,4)
+20 SET @FDARR@(1201)=$$NOW^TIULC
End DoDot:1
+21 SET @FDARR@(1205)=$PIECE($GET(TIU("LOC")),U)
+22 SET @FDARR@(1301)=$SELECT($GET(TIUDDT)]"":$$IDATE^TIULC($GET(TIUDDT)),1:"")
+23 IF $SELECT(@FDARR@(1301)'>0:1,$PIECE(@FDARR@(1301),".",2)']"":1,1:0)
Begin DoDot:1
+24 SET @FDARR@(1301)=$SELECT($PIECE($GET(TIU("VSTR")),";",3)="H":$$NOW^XLFDT,1:$GET(@FDARR@(.07)))
End DoDot:1
+25 SET @FDARR@(1303)="U"
+26 ; File record
DO FILE^DIE(FLAGS,"FDA","TIUMSG")
+27 QUIT
DELTEXT(DA) ; Delete existing text in preparation for replacement
+1 NEW DIE,DR,X,Y
+2 SET DIE=8925
SET DR="2///@"
DO ^DIE
+3 QUIT
WHATYPE(X) ; Identify document type
+1 ; Receives: X=Document Definition Name
+2 ; Returns: Y=Document Definition IFN
+3 NEW DIC,Y,TIUFPRIV
SET TIUFPRIV=1
+4 SET DIC=8925.1
SET DIC(0)="M"
+5 SET DIC("S")="I $D(^TIU(8925.1,+Y,""HEAD""))!$D(^TIU(8295.1,+Y,""ITEM""))"
+6 DO ^DIC
KILL DIC("S")
WHATYPX QUIT Y
WHATITLE(X) ; Identify document title
+1 ; Receives: X=Document Definition Name
+2 ; Returns: Y=Document Definition IFN
+3 NEW DIC,Y,TIUFPRIV
SET TIUFPRIV=1
+4 SET DIC=8925.1
SET DIC(0)="M"
+5 SET DIC("S")="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"""
+6 DO ^DIC
KILL DIC("S")
WHATITX QUIT Y
FOLLOWUP(TIUDA) ; Post-filing code for PROGRESS NOTES
+1 NEW FDA,FDARR,IENS,FLAGS,TIUMSG,TIU,DFN
+2 SET IENS=""""_TIUDA_","""
SET FDARR="FDA(8925,"_IENS_")"
SET FLAGS="K"
+3 SET @FDARR@(1204)=$$WHOSIGNS^TIULC1(TIUDA)
+4 IF +$PIECE($GET(^TIU(8925,TIUDA,12)),U,9)
IF '+$PIECE($GET(^(12)),U,8)
Begin DoDot:1
+5 SET @FDARR@(1208)=$$WHOCOSIG^TIULC1(TIUDA)
End DoDot:1
+6 DO FILE^DIE(FLAGS,"FDA","TIUMSG")
+7 IF +$PIECE($GET(^TIU(8925,+TIUDA,12)),U,8)
IF (+$PIECE($GET(^TIU(8925,+TIUDA,12)),U,4)'=+$PIECE($GET(^(12)),U,8))
Begin DoDot:1
+8 SET @FDARR@(1506)=1
DO FILE^DIE(FLAGS,"FDA","TIUMSG")
End DoDot:1
+9 DO RELEASE^TIUT(TIUDA,1)
+10 DO AUDIT^TIUEDI1(TIUDA,0,$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")"))
+11 IF '$DATA(TIU("VSTR"))
Begin DoDot:1
+12 NEW TIUD0,TIUD12,TIUVLOC,TIUHLOC,TIUEDT,TIULDT
+13 SET TIUD0=$GET(^TIU(8925,+TIUDA,0))
SET TIUD12=$GET(^(12))
+14 SET DFN=+$PIECE(TIUD0,U,2)
SET TIUEDT=+$PIECE(TIUD0,U,7)
+15 SET TIULDT=$$FMADD^XLFDT(TIUEDT,1)
SET TIUHLOC=+$PIECE(TIUD12,U,5)
+16 SET TIUVLOC=$SELECT(+$PIECE(TIUD12,U,11):+$PIECE(TIUD12,U,11),1:+TIUHLOC)
+17 IF $SELECT(+DFN'>0:1,+TIUEDT'>0:1,+TIULDT'>0:1,+TIUVLOC'>0:1,1:0)
QUIT
+18 DO MAIN^TIUVSIT(.TIU,DFN,"",TIUEDT,TIULDT,"LAST",0,+TIUVLOC)
End DoDot:1
+19 IF '$DATA(TIU("VSTR"))
QUIT
+20 ; Get/file VISIT
DO ENQ^TIUPXAP1
+21 QUIT
