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

AMERLKP.m

Go to the documentation of this file. 
  1. AMERLKP ;GDIT/HS/ALA-Patient Lookup ; 16 Oct 2013  7:49 AM
  1.  ;;3.0;ER VISIT SYSTEM;**5**;MAR 03, 2009;Build 14
  1.  ;
  1. SCAN ;EP
  1.  ;
  1.  NEW DIR,X,Y,TEXT,TYPE,II,BN,QFL,%H,%I
  1.  ;
  1.  S DIR("A")="Enter patient NAME, DOB, or LOCAL CHART NUMBER"
  1.  S DIR(0)="F^3:30"
  1.  D ^DIR
  1.  ;
  1.  ;NOTE: Since "DILIST" is used by the DIC calls it must use $J and not UID.
  1.  K ^TMP("DILIST",$J)
  1.  S TEXT=Y
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AMERLKP D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S TYPE=""
  1.  ;
  1.  ;Look for a DOB
  1.  I $$DATE(TEXT)'="" S TEXT=$$DATE(TEXT),TYPE="D"
  1.  ;
  1.  ;If no type of search was passed, the lookup will have to be through all cross-references
  1.  I TYPE="" D
  1.  . ;Change text to all uppercase
  1.  . NEW FILE,FIELD,XREF,FLAGS
  1.  . S TEXT=$$UP^XLFSTR(TEXT)
  1.  . S FILE=9000001,FIELD=".01",XREF="",FLAGS="PM"
  1.  . D LKUP
  1.  ;
  1.  ;If the type is 'D', do a date of birth lookup
  1.  I TYPE="D" D
  1.  . S FILE=2,FIELD=.03,XREF="ADOB",FLAGS="P"
  1.  . D LKUP
  1.  ;
  1.  ; For each patient found in the search, get the list data
  1.  S BN=0,QFL=0,II=0
  1.  F  S BN=$O(^TMP("DILIST",$J,BN)) Q:'BN  D  Q:(QFL'=0)
  1.  . NEW DFN,NAME,AUPDICW,ALIAS,AMXX,DIC
  1.  . S DFN=$P(^TMP("DILIST",$J,BN,0),"^",1)
  1.  . S NAME=$$GET1^DIQ(9000001,DFN_",",.01,"E")
  1.  . S AUPDICW="D IHSDUPE^AUPNLKID D ^AUPNLKID"
  1.  . S Y=DFN,II=II+1
  1.  . ;
  1.  . ;Perform audit log call
  1.  . D LOG^AMERBUSA("P","Q","AMERLKP","AMER: Scan Patient Names or Chart Numbers",DFN)
  1.  . ;
  1.  . ;Display the patient information
  1.  . I TEXT?1A.E,$E(NAME,1,$L(TEXT))'=TEXT S ALIAS=$$ALIAS(DFN,TEXT)
  1.  . S AMXX=^DPT(DFN,0),DIC="^DPT("
  1.  . W !,II_".  "_$S($G(ALIAS)'="":ALIAS_"  "_NAME,1:NAME) X AUPDICW
  1.  . I II#5=0 S QFL=$$ASK(II)
  1.  ;
  1.  ;Display the item
  1.  I QFL>0 D
  1.  . NEW DFN,NAME,AMXX,Y,AUPDICW,DIC,DIR,X,Y
  1.  . S DFN=$P(^TMP("DILIST",$J,QFL,0),U,1),NAME=$P(^DPT(DFN,0),U,1)
  1.  . S AMXX=^DPT(DFN,0),DIC="^DPT(",Y=DFN
  1.  . S AUPDICW="D IHSDUPE^AUPNLKID D ^AUPNLKID"
  1.  . W !!,NAME X AUPDICW
  1.  ;
  1.  ;Display prompt to continue
  1.  W !! S DIR(0)="E",DIR("A")="Press 'Return to continue"
  1.  D ^DIR
  1.  ;
  1. DONE ;
  1.  K ^TMP("DILIST",$J)
  1.  Q
  1.  ;
  1. LKUP D FIND^DIC(FILE,"",FIELD,FLAGS,TEXT,"",XREF,"","","","ERROR")
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  Q
  1.  ;
  1. ASK(II) ;Patient Prompt
  1.  NEW DA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
  1.  S DIR(0)="FAO^0:5",DIR("A")="CHOOSE 1-"_II_": "
  1.  D ^DIR
  1.  I Y="^" S Y="-1" Q Y
  1.  I Y'?1N.N S Y="0"
  1.  Q Y
  1.  ;
  1. ALIAS(PTIEN,TEXT) ;EP
  1.  ; Does this patient's alias match the TEXT?
  1.  N IEN,ALIAS,ALFND
  1.  S IEN=0,ALFND=""
  1.  F  S IEN=$O(^DPT(PTIEN,.01,IEN)) Q:'IEN!ALFND  D
  1.  . S ALIAS=$$GET1^DIQ(2.01,IEN_","_PTIEN_",",.01,"E")
  1.  . I $E(ALIAS,1,$L(TEXT))=TEXT S ALFND=ALIAS
  1.  Q ALFND
  1.  ;
  1. DATE(DATE) ;EP - Convert standard date/time to a FileMan date/time
  1.  ;Input
  1.  ;  DATE - In a standard format
  1.  ;Output
  1.  ;  -1 is if it couldn't convert to a FileMan date
  1.  ;  otherwise a standard FileMan date
  1.  NEW %DT,X,Y
  1.  I DATE[":" D
  1.  . I DATE["/",$L(DATE," ")=3 S DATE=$P(DATE," ",1)_"@"_$P(DATE," ",2)_$P(DATE," ",3) Q
  1.  . I $L(DATE," ")=3 S DATE=$P(DATE," ",1,2)_"@"_$P(DATE," ",3)
  1.  . I $L(DATE," ")>3 S DATE=$P(DATE," ",1,3)_"@"_$P(DATE," ",4,99)
  1.  S %DT="TS",X=DATE D ^%DT
  1.  I Y=-1 S Y=""
  1.  ;
  1.  Q Y