- BEHODCS ;MSC/IND/MGH - TIU Discharge Summary 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,CREATE,BEHTIU,BEHDFN
- IEN ;Get data needed to identify note
- I $S('$D(TIUNAME):1,'$D(TIUHRN):1,'$D(TIUADT):1,1:0) S Y=-1 G LOOKUPX
- S BEHTIU=+$G(TIUHDR("TIUHRN")) S DFN=$$CKHRN(BEHTIU)
- 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)
- S TIUEDT=$$IDATE^TIULC(TIUADT),TIULDT=$$FMADD^XLFDT(TIUEDT,1)
- I +TIUEDT'>0 S Y=-1 Q
- D NAMECK I $G(Y)=-1 Q
- D MAIN^TIUMOVE(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,1,"LAST",0)
- I $S($D(TIU)'>9:1,+$G(DFN)'>0:1,1:0) S Y=-1 G LOOKUPX
- I $P(+$G(TIU("EDT")),".")'=$P($$IDATE^TIULC(TIUADT),".") S Y=-1 G LOOKUPX
- I '+$G(TIU("LDT")),($G(TIUDICDT)]""),(+$$IDATE^TIULC(TIUDICDT)=-1) S Y=-1 Q
- D DOCPRM^TIULC1(RECORD("TYPE"),.TIUDPRM)
- S TIUTYP(1)=1_U_RECORD("TYPE")_U_$$PNAME^TIULC1(RECORD("TYPE"))
- S Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
- I +Y'>0 G LOOKUPX
- S TIUEDIT=$$CANEDIT(+Y)
- ;If record has text and can be edited, then replace existing text
- I +TIUEDIT>0,$D(^TIU(8925,+Y,"TEXT")) D DELTEXT(+Y)
- I +TIUEDIT'>0 S TIUDAD=+Y,Y=$$MAKENADD
- I +Y'>0 G LOOKUPX
- D STUFREC(Y,+$G(TIUDAD))
- I +$G(TIUDAD) D SENDADD^TIUALRT(+Y)
- K TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
- LOOKUPX 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(TIUNAME,",",1),LNAME2=$P(TIUNAME2,",",1)
- I LNAME1'=LNAME2 S Y=-1
- Q
- 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=$$MAKENADD
- I +Y'>0 Q
- D STUFREC(Y,+$G(TIUDAD))
- I +$G(TIUDAD) D SENDADD^TIUALRT(+Y)
- K TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
- 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)
- MAKENADD() ; 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),@FDARR@(1401)=TIU("AD#")
- . S @FDARR@(1201)=$$NOW^TIULC
- . S @FDARR@(1402)=$P($G(TIU("TS")),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,@FDARR@(.08)=$P($G(^TIU("LDT")),U)
- . S @FDARR@(1401)=$P($G(^TIU(8925,+PARENT,14)),U)
- . S @FDARR@(1402)=$P($G(^TIU(8925,+PARENT,14)),U,2)
- . S @FDARR@(1201)=$$NOW^TIULC
- S @FDARR@(1205)=$P($G(TIU("LOC")),U)
- I +$G(TIU("LDT")) S TIURDT=+$G(TIU("LDT"))
- I +$G(TIU("LDT"))'>0 D
- .S TIUDICDT=+$$IDATE^TIULC($G(TIUDICDT))
- .S TIURDT=$S(+$G(TIUICDT)>0:+$G(TIUDICDT),1:+$$NOW^TIULC)
- .S TIU("LDT")=TIURDT_U_$$DATE^TIULS(TIURDT,"AMTH DD, CCYY@HR:MIN:SEC")
- .S @FDARR@(.12)=1
- S @FDARR@(1301)=TIURDT,@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"
- D GETTIU^TIULD(.TIU,TIUDA)
- I $L($G(TIU("EDT"))) S @FDARR@(.07)=$P($G(TIU("EDT")),U)
- S @FDARR@(1204)=$$WHOSIGNS^TIULC1(TIUDA)
- S @FDARR@(1208)=$$WHOCOSIG^TIULC1(TIUDA)
- D FILE^DIE(FLAGS,"FDA","TIUMSG")
- I $D(^TIU(8925,+TIUDA,12)),+$P(^(12),U,4)'=+$P(^(12),U,9) D
- . S @FDARR@(1506)=1 D FILE^DIE(FLAGS,"FDA","TIUMSG")
- D ENQ^TIUPXAP1 ; get/file visit
- D RELEASE^TIUT(TIUDA,1)
- D AUDIT^TIUEDI1(TIUDA,0,$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")"))
- Q
- BEHODCS ;MSC/IND/MGH - TIU Discharge Summary 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,CREATE,BEHTIU,BEHDFN
- IEN ;Get data needed to identify note
- +1 IF $SELECT('$DATA(TIUNAME):1,'$DATA(TIUHRN):1,'$DATA(TIUADT):1,1:0)
- SET Y=-1
- GOTO LOOKUPX
- +2 SET BEHTIU=+$GET(TIUHDR("TIUHRN"))
- SET DFN=$$CKHRN(BEHTIU)
- +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 SET TIUEDT=$$IDATE^TIULC(TIUADT)
- SET TIULDT=$$FMADD^XLFDT(TIUEDT,1)
- +7 IF +TIUEDT'>0
- SET Y=-1
- QUIT
- +8 DO NAMECK
- IF $GET(Y)=-1
- QUIT
- +9 DO MAIN^TIUMOVE(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,1,"LAST",0)
- +10 IF $SELECT($DATA(TIU)'>9:1,+$GET(DFN)'>0:1,1:0)
- SET Y=-1
- GOTO LOOKUPX
- +11 IF $PIECE(+$GET(TIU("EDT")),".")'=$PIECE($$IDATE^TIULC(TIUADT),".")
- SET Y=-1
- GOTO LOOKUPX
- +12 IF '+$GET(TIU("LDT"))
- IF ($GET(TIUDICDT)]"")
- IF (+$$IDATE^TIULC(TIUDICDT)=-1)
- SET Y=-1
- QUIT
- +13 DO DOCPRM^TIULC1(RECORD("TYPE"),.TIUDPRM)
- +14 SET TIUTYP(1)=1_U_RECORD("TYPE")_U_$$PNAME^TIULC1(RECORD("TYPE"))
- +15 SET Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
- +16 IF +Y'>0
- GOTO LOOKUPX
- +17 SET TIUEDIT=$$CANEDIT(+Y)
- +18 ;If record has text and can be edited, then replace existing text
- +19 IF +TIUEDIT>0
- IF $DATA(^TIU(8925,+Y,"TEXT"))
- DO DELTEXT(+Y)
- +20 IF +TIUEDIT'>0
- SET TIUDAD=+Y
- SET Y=$$MAKENADD
- +21 IF +Y'>0
- GOTO LOOKUPX
- +22 DO STUFREC(Y,+$GET(TIUDAD))
- +23 IF +$GET(TIUDAD)
- DO SENDADD^TIUALRT(+Y)
- +24 KILL TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
- LOOKUPX QUIT
- +1 ; Returns patient for given HRN and DUZ(2) value
- +2 ; Input - BEHTIU - Health Record Number
- +3 ; Assumes - DUZ(2) is set to currently facility
- +4 ; 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(TIUNAME,",",1)
- SET LNAME2=$PIECE(TIUNAME2,",",1)
- +3 IF LNAME1'=LNAME2
- SET Y=-1
- +4 QUIT
- +5 IF +Y'>0
- GOTO LOOKUPX
- +6 ; If record is not new, has text and can be edited, then replace
- +7 ; existing text
- +8 IF +$GET(TIUNEW)'>0
- Begin DoDot:1
- +9 SET TIUEDIT=$$CANEDIT(+Y)
- +10 IF +TIUEDIT>0
- IF $DATA(^TIU(8925,+Y,"TEXT"))
- DO DELTEXT(+Y)
- +11 IF +TIUEDIT'>0
- SET TIUDAD=+Y
- SET Y=$$MAKENADD
- End DoDot:1
- +12 IF +Y'>0
- QUIT
- +13 DO STUFREC(Y,+$GET(TIUDAD))
- +14 IF +$GET(TIUDAD)
- DO SENDADD^TIUALRT(+Y)
- +15 KILL TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
- +16 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)
- MAKENADD() ; 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)
- SET @FDARR@(1401)=TIU("AD#")
- +8 SET @FDARR@(1201)=$$NOW^TIULC
- +9 SET @FDARR@(1402)=$PIECE($GET(TIU("TS")),U)
- End DoDot:1
- +10 IF +$GET(PARENT)>0
- Begin DoDot:1
- +11 SET @FDARR@(.02)=+$PIECE($GET(^TIU(8925,+PARENT,0)),U,2)
- +12 SET @FDARR@(.03)=+$PIECE($GET(^TIU(8925,+PARENT,0)),U,3)
- SET @FDARR@(.05)=3
- +13 SET @FDARR@(.06)=PARENT
- SET @FDARR@(.08)=$PIECE($GET(^TIU("LDT")),U)
- +14 SET @FDARR@(1401)=$PIECE($GET(^TIU(8925,+PARENT,14)),U)
- +15 SET @FDARR@(1402)=$PIECE($GET(^TIU(8925,+PARENT,14)),U,2)
- +16 SET @FDARR@(1201)=$$NOW^TIULC
- End DoDot:1
- +17 SET @FDARR@(1205)=$PIECE($GET(TIU("LOC")),U)
- +18 IF +$GET(TIU("LDT"))
- SET TIURDT=+$GET(TIU("LDT"))
- +19 IF +$GET(TIU("LDT"))'>0
- Begin DoDot:1
- +20 SET TIUDICDT=+$$IDATE^TIULC($GET(TIUDICDT))
- +21 SET TIURDT=$SELECT(+$GET(TIUICDT)>0:+$GET(TIUDICDT),1:+$$NOW^TIULC)
- +22 SET TIU("LDT")=TIURDT_U_$$DATE^TIULS(TIURDT,"AMTH DD, CCYY@HR:MIN:SEC")
- +23 SET @FDARR@(.12)=1
- End DoDot:1
- +24 SET @FDARR@(1301)=TIURDT
- SET @FDARR@(1303)="U"
- +25 ; File record
- DO FILE^DIE(FLAGS,"FDA","TIUMSG")
- +26 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 DO GETTIU^TIULD(.TIU,TIUDA)
- +4 IF $LENGTH($GET(TIU("EDT")))
- SET @FDARR@(.07)=$PIECE($GET(TIU("EDT")),U)
- +5 SET @FDARR@(1204)=$$WHOSIGNS^TIULC1(TIUDA)
- +6 SET @FDARR@(1208)=$$WHOCOSIG^TIULC1(TIUDA)
- +7 DO FILE^DIE(FLAGS,"FDA","TIUMSG")
- +8 IF $DATA(^TIU(8925,+TIUDA,12))
- IF +$PIECE(^(12),U,4)'=+$PIECE(^(12),U,9)
- Begin DoDot:1
- +9 SET @FDARR@(1506)=1
- DO FILE^DIE(FLAGS,"FDA","TIUMSG")
- End DoDot:1
- +10 ; get/file visit
- DO ENQ^TIUPXAP1
- +11 DO RELEASE^TIUT(TIUDA,1)
- +12 DO AUDIT^TIUEDI1(TIUDA,0,$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")"))
- +13 QUIT