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

BEHODCP.m

Go to the documentation of this file. 
  1. 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
  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,BEHDFN,CREATE,BEHTIU,TIUNAME2,TIUVSTRB
  1. IEN ;Get data needed to identify note
  1.  S BEHTIU=+$G(TIUHDR("TIUHRN")) S DFN=$$CKHRN(BEHTIU)
  1.  ;I $S('$D(TIUNAME):1,'$D(TIUVDT):1,1:0) S Y=-1 G LOOKUPX
  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.  ; Check clinic name
  1.  I '$G(TIUHDR("TIUIEN")) D  G:Y=-1 LOOKUPX
  1.  .I '$L($G(TIULOC)) S Y=-1 Q
  1.  .S TIULOC=+$$ILOC(TIULOC)
  1.  .I '$D(^SC(+$G(TIULOC),0)) S Y=-1
  1.  ; Check appointment date
  1.  I '$G(TIUHDR("TIUIEN")) D  G:Y=-1 LOOKUPX
  1.  .S TIUEDT=$$IDATE(+$G(TIUVDT)),TIULDT=$$FMADD^XLFDT(TIUEDT,1)
  1.  .I +TIUEDT'>0 S Y=-1
  1.  S TIUTYPE=$$WHATITLE(TIUTITLE)
  1.  I +TIUTYPE'>0 S Y=-1 G LOOKUPX
  1.  D DOCPRM^TIULC1(+TIUTYPE,.TIUDPRM)
  1.  I $G(TIUHDR("TIUIEN"))="" D NAMECK,REGULAR:Y'=-1
  1.  I $G(TIUHDR("TIUIEN"))'="" D SPECIAL,REGULAR:Y'=-1
  1.  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($G(TIUNAME),","),LNAME2=$P(TIUNAME2,",")
  1.  I LNAME1'=LNAME2 S Y=-1
  1.  Q
  1. SPECIAL ;If the note ien exists, make sure its the correct one
  1.  S TIUIEN=$G(TIUHDR("TIUIEN"))
  1.  I $G(^TIU(8925,TIUIEN,0))="" S Y=-1 Q
  1.  I $P($G(^TIU(8925,TIUIEN,0)),U,2)'=DFN S TIUIEN="",Y=-1 Q
  1.  I $P($G(^TIU(8925,TIUIEN,0)),U,1)'=$P(TIUTYPE,U,1) S TIUIEN="",Y=-1 Q
  1.  S TIULOC=$P($G(^TIU(8925,TIUIEN,12)),U,5)
  1.  S TIUEDT=$P($G(^TIU(8925,TIUIEN,0)),U,7)
  1.  S TIULDT=$P($G(^TIU(8925,TIUIEN,0)),U,8)
  1.  S TIUVISIT=$P($G(^TIU(8925,TIUIEN,0)),U,3)
  1.  Q
  1. REGULAR ;Get the visit
  1.  I $P($G(^SC(+$G(TIULOC),0)),U,3)="W" S TIUSC="H"
  1.  E  S TIUSC="A"
  1.  S TIUVSTR=TIULOC_";"_TIUEDT_";"_TIUSC
  1.  ;The variable TIUVSTR needs the fourth element (the IEN) if the
  1.  ;visit is known. However, the TIU lookup routine does not use this
  1.  ;element so both of them have to be saved
  1.  I $D(TIUIEN) S TIUVSTRB=TIUVSTR_";"_$G(TIUVISIT)
  1.  E  S TIUVSTRB=TIUVSTR
  1.  S CREATE=1
  1.  ;Find the visit or make a new one
  1.  S TIUVISIT=$$VSTR2VIS^BEHOENCX(DFN,TIUVSTRB,CREATE)
  1.  S TIUVSTR=$P(TIUVSTRB,";",1,3)
  1.  ;Get the variables for the TIU array
  1.  D PATVADPT^TIULV(.TIU,DFN,"",TIUVSTR)
  1.  S TIUTYP(1)=1_U_TIUTYPE_U_$$PNAME^TIULC1(TIUTYPE)
  1.  ;Store record
  1.  I +$G(TIUIEN) D
  1.  .S Y=TIUIEN
  1.  E  S Y=$$GETRECNW^TIUEDI3(DFN,.TIU,TIUTYP(1),.TIUNEW,.TIUDPRM)
  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=$$MAKEADD
  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. LOOKUPX 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. MAKEADD() ; 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)
  1.  . S @FDARR@(1201)=$$NOW^TIULC
  1.  . S @FDARR@(1205)=$S(+$P($G(TIU("LOC")),U):$P($G(TIU("LOC")),U),1:$P($G(TIU("VLOC")),U))
  1.  . ;S @FDARR@(1211)=$P($G(TIU("VLOC")),U)
  1.  . S @FDARR@(1404)=$P($G(TIU("SVC")),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
  1.  . S @FDARR@(.07)=$P($G(^TIU(8925,+PARENT,0)),U,7)
  1.  . S @FDARR@(.08)=$P($G(^TIU(8925,+PARENT,0)),U,8)
  1.  . S @FDARR@(1205)=$P($G(^TIU(8925,+PARENT,12)),U,5)
  1.  . S @FDARR@(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4)
  1.  . S @FDARR@(1201)=$$NOW^TIULC
  1.  S @FDARR@(1205)=$P($G(TIU("LOC")),U)
  1.  S @FDARR@(1301)=$S($G(TIUDDT)]"":$$IDATE^TIULC($G(TIUDDT)),1:"")
  1.  I $S(@FDARR@(1301)'>0:1,$P(@FDARR@(1301),".",2)']"":1,1:0) D
  1.  . S @FDARR@(1301)=$S($P($G(TIU("VSTR")),";",3)="H":$$NOW^XLFDT,1:$G(@FDARR@(.07)))
  1.  S @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.  S @FDARR@(1204)=$$WHOSIGNS^TIULC1(TIUDA)
  1.  I +$P($G(^TIU(8925,TIUDA,12)),U,9),'+$P($G(^(12)),U,8) D
  1.  . S @FDARR@(1208)=$$WHOCOSIG^TIULC1(TIUDA)
  1.  D FILE^DIE(FLAGS,"FDA","TIUMSG")
  1.  I +$P($G(^TIU(8925,+TIUDA,12)),U,8),(+$P($G(^TIU(8925,+TIUDA,12)),U,4)'=+$P($G(^(12)),U,8)) D
  1.  . S @FDARR@(1506)=1 D FILE^DIE(FLAGS,"FDA","TIUMSG")
  1.  D RELEASE^TIUT(TIUDA,1)
  1.  D AUDIT^TIUEDI1(TIUDA,0,$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")"))
  1.  I '$D(TIU("VSTR")) D
  1.  . N TIUD0,TIUD12,TIUVLOC,TIUHLOC,TIUEDT,TIULDT
  1.  . S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^(12))
  1.  . S DFN=+$P(TIUD0,U,2),TIUEDT=+$P(TIUD0,U,7)
  1.  . S TIULDT=$$FMADD^XLFDT(TIUEDT,1),TIUHLOC=+$P(TIUD12,U,5)
  1.  . S TIUVLOC=$S(+$P(TIUD12,U,11):+$P(TIUD12,U,11),1:+TIUHLOC)
  1.  . I $S(+DFN'>0:1,+TIUEDT'>0:1,+TIULDT'>0:1,+TIUVLOC'>0:1,1:0) Q
  1.  . D MAIN^TIUVSIT(.TIU,DFN,"",TIUEDT,TIULDT,"LAST",0,+TIUVLOC)
  1.  Q:'$D(TIU("VSTR"))
  1.  D ENQ^TIUPXAP1 ; Get/file VISIT
  1.  Q