Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BEHODCS

BEHODCS.m

Go to the documentation of this file.
  1. 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
  1. ;=================================================================
  1. ;Functionally the same as TIUPUTPN except modified to use note IEN
  1. ;and not to use SSN for patient identifier.
  1. ;===============================================================
  1. LOOKUP ; Look-up code used by router/filer
  1. ; Required: TIUHRN, TIUVDT
  1. N DA,DFN,TIU,TIUDAD,TIUEDIT,TIUEDT,TIULDT,TIUXCRP,TIUTYPE,TIUNEW
  1. N TIUDPRM,TIUIEN,CREATE,BEHTIU,BEHDFN
  1. IEN ;Get data needed to identify note
  1. I $S('$D(TIUNAME):1,'$D(TIUHRN):1,'$D(TIUADT):1,1:0) S Y=-1 G LOOKUPX
  1. S BEHTIU=+$G(TIUHDR("TIUHRN")) S DFN=$$CKHRN(BEHTIU)
  1. I DFN="" S Y=-1 G LOOKUPX
  1. S TIUNAME2=$P($G(^DPT(DFN,0)),U,1)
  1. S TIUSSN=$P($G(^DPT(DFN,0)),U,9)
  1. S TIUEDT=$$IDATE^TIULC(TIUADT),TIULDT=$$FMADD^XLFDT(TIUEDT,1)
  1. I +TIUEDT'>0 S Y=-1 Q
  1. D NAMECK I $G(Y)=-1 Q
  1. D MAIN^TIUMOVE(.TIU,.DFN,TIUSSN,TIUEDT,TIULDT,1,"LAST",0)
  1. I $S($D(TIU)'>9:1,+$G(DFN)'>0:1,1:0) S Y=-1 G LOOKUPX
  1. I $P(+$G(TIU("EDT")),".")'=$P($$IDATE^TIULC(TIUADT),".") S Y=-1 G LOOKUPX
  1. I '+$G(TIU("LDT")),($G(TIUDICDT)]""),(+$$IDATE^TIULC(TIUDICDT)=-1) S Y=-1 Q
  1. D DOCPRM^TIULC1(RECORD("TYPE"),.TIUDPRM)
  1. S TIUTYP(1)=1_U_RECORD("TYPE")_U_$$PNAME^TIULC1(RECORD("TYPE"))
  1. S Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
  1. I +Y'>0 G LOOKUPX
  1. S TIUEDIT=$$CANEDIT(+Y)
  1. ;If record has text and can be edited, then replace existing text
  1. I +TIUEDIT>0,$D(^TIU(8925,+Y,"TEXT")) D DELTEXT(+Y)
  1. I +TIUEDIT'>0 S TIUDAD=+Y,Y=$$MAKENADD
  1. I +Y'>0 G LOOKUPX
  1. D STUFREC(Y,+$G(TIUDAD))
  1. I +$G(TIUDAD) D SENDADD^TIUALRT(+Y)
  1. K TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
  1. LOOKUPX Q
  1. ; Returns patient for given HRN and DUZ(2) value
  1. ; Input - BEHTIU - Health Record Number
  1. ; Assumes - DUZ(2) is set to currently facility
  1. ; Returns - DFN or ""
  1. CKHRN(BEHTIU) ;If entered name doesn't match a patient, use the Health
  1. ;Record Number if available.
  1. N INST,DFN,RES
  1. S BEHTIU=$G(BEHTIU,""),RES=""
  1. I BEHTIU'="" D
  1. .S DFN=0 F S DFN=$O(^AUPNPAT("D",BEHTIU,DFN)) Q:'DFN!RES D
  1. ..S INST=0 F S INST=$O(^AUPNPAT("D",BEHTIU,DFN,INST)) Q:'INST!RES D
  1. ...S:INST=DUZ(2) RES=DFN
  1. Q RES
  1. NAMECK ;If no note ien, check last name entered with last name from HRN
  1. N LNAME1,LNAME2
  1. S LNAME1=$P(TIUNAME,",",1),LNAME2=$P(TIUNAME2,",",1)
  1. I LNAME1'=LNAME2 S Y=-1
  1. Q
  1. I +Y'>0 G LOOKUPX
  1. ; If record is not new, has text and can be edited, then replace
  1. ; existing text
  1. I +$G(TIUNEW)'>0 D
  1. . S TIUEDIT=$$CANEDIT(+Y)
  1. . I +TIUEDIT>0,$D(^TIU(8925,+Y,"TEXT")) D DELTEXT(+Y)
  1. . I +TIUEDIT'>0 S TIUDAD=+Y,Y=$$MAKENADD
  1. I +Y'>0 Q
  1. D STUFREC(Y,+$G(TIUDAD))
  1. I +$G(TIUDAD) D SENDADD^TIUALRT(+Y)
  1. K TIUHDR(.01),TIUHDR(.07),TIUHDR(1301)
  1. Q
  1. IDATE(X) ; Receives date in external format, returns internal format
  1. N %DT,Y
  1. I ($L(X," ")=2),(X?1.2N1P1.2N1P1.2N.2N1" "1.2N.E) S X=$TR(X," ","@")
  1. S %DT="TSP" D ^%DT
  1. Q Y
  1. ILOC(LOCATION) ; Get pointer to file 44
  1. N DIC,X,Y
  1. S DIC=44,DIC(0)="M",X=LOCATION D ^DIC
  1. Q Y
  1. CANEDIT(DA) ; Check whether or not document is in a status up to unsigned
  1. Q $S(+$P($G(^TIU(8925,+DA,0)),U,5)<6:1,1:0)
  1. MAKENADD() ; Create an addendum record
  1. N DIE,DR,DA,DIC,X,Y,DLAYGO,TIUATYP,TIUFPRIV S TIUFPRIV=1
  1. S TIUATYP=+$$WHATITLE("ADDENDUM")
  1. S (DIC,DLAYGO)=8925,DIC(0)="L",X=""""_"`"_TIUATYP_""""
  1. D ^DIC
  1. S DA=+Y
  1. I +DA>0 S DIE=DIC,DR=".04////"_$$DOCCLASS^TIULC1(TIUATYP) D ^DIE
  1. K TIUHDR(.01)
  1. Q +DA
  1. STUFREC(DA,PARENT) ; Stuff fixed field data
  1. N FDA,FDARR,IENS,FLAGS,TIUMSG
  1. S IENS=""""_DA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
  1. I +$G(PARENT)'>0 D
  1. . S @FDARR@(.02)=$G(DFN),@FDARR@(.03)=$P($G(TIU("VISIT")),U)
  1. . S @FDARR@(.05)=3
  1. . S @FDARR@(.07)=$P($G(TIU("EDT")),U)
  1. . S @FDARR@(.08)=$P($G(TIU("LDT")),U),@FDARR@(1401)=TIU("AD#")
  1. . S @FDARR@(1201)=$$NOW^TIULC
  1. . S @FDARR@(1402)=$P($G(TIU("TS")),U)
  1. I +$G(PARENT)>0 D
  1. . S @FDARR@(.02)=+$P($G(^TIU(8925,+PARENT,0)),U,2)
  1. . S @FDARR@(.03)=+$P($G(^TIU(8925,+PARENT,0)),U,3),@FDARR@(.05)=3
  1. . S @FDARR@(.06)=PARENT,@FDARR@(.08)=$P($G(^TIU("LDT")),U)
  1. . S @FDARR@(1401)=$P($G(^TIU(8925,+PARENT,14)),U)
  1. . S @FDARR@(1402)=$P($G(^TIU(8925,+PARENT,14)),U,2)
  1. . S @FDARR@(1201)=$$NOW^TIULC
  1. S @FDARR@(1205)=$P($G(TIU("LOC")),U)
  1. I +$G(TIU("LDT")) S TIURDT=+$G(TIU("LDT"))
  1. I +$G(TIU("LDT"))'>0 D
  1. .S TIUDICDT=+$$IDATE^TIULC($G(TIUDICDT))
  1. .S TIURDT=$S(+$G(TIUICDT)>0:+$G(TIUDICDT),1:+$$NOW^TIULC)
  1. .S TIU("LDT")=TIURDT_U_$$DATE^TIULS(TIURDT,"AMTH DD, CCYY@HR:MIN:SEC")
  1. .S @FDARR@(.12)=1
  1. S @FDARR@(1301)=TIURDT,@FDARR@(1303)="U"
  1. D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
  1. Q
  1. DELTEXT(DA) ; Delete existing text in preparation for replacement
  1. N DIE,DR,X,Y
  1. S DIE=8925,DR="2///@" D ^DIE
  1. Q
  1. WHATYPE(X) ; Identify document type
  1. ; Receives: X=Document Definition Name
  1. ; Returns: Y=Document Definition IFN
  1. N DIC,Y,TIUFPRIV S TIUFPRIV=1
  1. S DIC=8925.1,DIC(0)="M"
  1. S DIC("S")="I $D(^TIU(8925.1,+Y,""HEAD""))!$D(^TIU(8295.1,+Y,""ITEM""))"
  1. D ^DIC K DIC("S")
  1. WHATYPX Q Y
  1. WHATITLE(X) ; Identify document title
  1. ; Receives: X=Document Definition Name
  1. ; Returns: Y=Document Definition IFN
  1. N DIC,Y,TIUFPRIV S TIUFPRIV=1
  1. S DIC=8925.1,DIC(0)="M"
  1. S DIC("S")="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"""
  1. D ^DIC K DIC("S")
  1. WHATITX Q Y
  1. FOLLOWUP(TIUDA) ; Post-filing code for PROGRESS NOTES
  1. N FDA,FDARR,IENS,FLAGS,TIUMSG,TIU,DFN
  1. S IENS=""""_TIUDA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
  1. D GETTIU^TIULD(.TIU,TIUDA)
  1. I $L($G(TIU("EDT"))) S @FDARR@(.07)=$P($G(TIU("EDT")),U)
  1. S @FDARR@(1204)=$$WHOSIGNS^TIULC1(TIUDA)
  1. S @FDARR@(1208)=$$WHOCOSIG^TIULC1(TIUDA)
  1. D FILE^DIE(FLAGS,"FDA","TIUMSG")
  1. I $D(^TIU(8925,+TIUDA,12)),+$P(^(12),U,4)'=+$P(^(12),U,9) D
  1. . S @FDARR@(1506)=1 D FILE^DIE(FLAGS,"FDA","TIUMSG")
  1. D ENQ^TIUPXAP1 ; get/file visit
  1. D RELEASE^TIUT(TIUDA,1)
  1. D AUDIT^TIUEDI1(TIUDA,0,$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")"))
  1. Q