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

BGUCEKT.m

Go to the documentation of this file. 
  1. BGUCEKT ; IHS/OIT/MJL - GENERAL PATIENT LOOKUP FOR BGU WINDOWS ;
  1.  ;;1.5;BGU;;MAY 26, 2005
  1.  ;GUI from PTLIST^BGUKT
  1.  ;
  1.  ;===================================================================
  1. PTLIST(RESULT,X)        ;-get list of patients and pass back
  1.  ;INPUTS : X = SEARCH-KEY | BGUMAX
  1.  ;         SEARCH-KEY = used to limit the search.
  1.  ;            = partial last name - use PTLIST^BGUKT().
  1.  ;                   - RETURNS A LIST
  1.  ;            = 1st letter of LAST name +  4 digits of SSN- DPT("BS5"
  1.  ;                   - RETURNS A LIST
  1.  ;            = DOB   - ^DPT("ADOB",DOB
  1.  ;                   - RETURNS EXACT FIND
  1.  ;            = Chart Number(all numeric) - use FIND^DIC call W/ EXACT
  1.  ;                -  ^AUPNPAT("D",    - RETURNS EXACT FIND
  1.  ;            = SSN - (ALL numeric) - DPT("SSN" - use FIND^DIC call 
  1.  ;                   - RETURNS EXACT FIND
  1.  ;            = LOC - dont know what to do right now. - DPT("CN"
  1.  ;         BGUMAX = max number of records to send per call.
  1.  ;        ^DD("DD") = "S Y=$$FMTE^DILIBF(Y,""5U"")"  - disp day of week 
  1.  ;
  1.  ;if SEARCH-KEY is 1-6 digits - search by Chart Number.
  1.  ;                   9 digits - search by SSN
  1.  ;                 1A4N       - search by A1N4
  1.  ;              contains "/", - search by DOB
  1.  ;ELSE                        - search by partial name.
  1.  ;OUTPUTS: RESULT() = NAME^DFN^DOB^SSN^HRCN
  1.  ;
  1.  K BGUDATA,RESULT
  1.  N BGUCOUNT,BGUDFN,BGUMAX,BGUZROS
  1.  S BGUMAX=$P(X,"|",2),X=$P(X,"|")
  1.  S BGUQT="""",RESULT(0.01)=0
  1.  ;
  1.  S BGUROOT="^BGUCTMP("_$J,TROOT=BGUROOT_")"
  1.  S TROOT=BGUROOT_")",MROOT=BGUROOT_","_BGUQT_"ERRMSG"_BGUQT_")"
  1.  K @TROOT
  1.  ;
  1.  ;LIST - FIRST letter of last name and 4 digits of SSN:
  1.  I X?1A4N D A1N4 Q
  1.  ;
  1.  ;FIND - If X contains "/", this is DOB (so DOB input must contain "/").
  1.  I X["/" D DOB Q
  1.  ; 
  1.  ;FIND - SSN - EXACT 9 digits.  ADD ;.09 would give SSN, but...
  1.  I X?9N D SSN Q
  1.  ;
  1.  ;FIND - Chart Number - EXACT 1-6 digits.   ^AUPNPAT("D",CHRT,DFN,FAC)
  1.  ;In SCREEN^DICL2(), DIENTRY = the curr. chart number, DIEN=DFN.
  1.  I X?1.6N D CHRT Q
  1.  ;
  1.  ;LIST - Assume PARTIAL NAME search ;I X?.A." ".A.",".A." ".A D LSTNM Q
  1.  D LSTNM,KILL
  1.  Q
  1.  ;
  1. A1N4 ;LIST
  1.  S FILE=2,INDEX="BS5",FIELDS=".01",X1=$E(X),X2=$E(X,2,5)+10000
  1.  S:X2'="10000" X2=X2-1,X=$E(X)_$E(X2,2,5)
  1.  S:X2=10000 X1=$C($A(X1)-1),X=X1_9999
  1.  S BGUNX="S BGUSTRT=$E(NM)_$E(SSN,1,4)"
  1.  D DICLST,FMTOUT,KILL
  1.  Q
  1.  ;
  1. DOB ;LOOK UP BY DOB- EXACT MATCH FIND
  1.  ;DOB is a regular field in 2.   DOB is a COMPUTED field in 9000001.
  1.  S FILE=2,INDEX="ADOB",FIELDS=".01"
  1.  S BGUNX="S BGUSTRT=DOB"
  1.  D DICFIND,FMTOUT,KILL
  1.  Q
  1.  ;
  1. SSN ;EXACT MATCH FIND
  1.  ;LIST- S X=1000000000+X-1,X=$E(X,2,10) D DICLST,FMTOUT,KILL Q
  1.  S FILE=2,INDEX="SSN",FIELDS=".01;.09"
  1.  S BGUNX="S BGUSTRT=SSN"
  1.  D DICFIND,FMTOUT,KILL
  1.  Q
  1.  ;
  1. CHRT ;EXACT MATCH FIND - 1 to 6 digits (No Leading zeros)
  1.  ;LIST^DIC- In SCREEN^DICL2(), DIENTRY=the curr. chart number, DIEN=DFN.
  1.  ;S SCREEN="I $D(^AUPNPAT(""D"",DIENTRY,DIEN,DUZ(2)))"
  1.  ;S $P(BGUZROS,"0",$L(X)+1)="",BGUZROS=1_BGUZROS,X=BGUZROS+X-1,X=$E(X,2,$L(X))
  1.  ;FIND^DIC- In ^DICF3,      DIVALUE=the curr. chart number, DIENTRY=DFN.
  1.  S SCREEN="I $D(^AUPNPAT(""D"",DIVALUE,DIENTRY,DUZ(2)))"
  1.  S FILE=9000001,INDEX="D",FIELDS=".01"
  1.  S BGUNX="S BGUSTRT=CHRT"
  1.  D DICFIND,FMTOUT,KILL
  1.  Q
  1.  ; 
  1. DICLST ;SETUP to call LIST^DIC( ) - SCREEN code is executed in ^DIL2C
  1.  S IEN="",FLAGS=""
  1.  S NUMBER=BGUMAX+1,FROM=X
  1.  S PART="",IDNTIFIR="",SCREEN=$G(SCREEN)
  1.  D LIST^DIC(FILE,IEN,FIELDS,FLAGS,NUMBER,FROM,PART,INDEX,SCREEN,IDNTIFIR,TROOT)
  1.  Q
  1.  ;
  1. DICFIND ;SETUP to call FIND^DIC() - SCREEN code is executed in ^DICF3
  1.  S IEN="",FLAGS=""
  1.  S NUMBER=BGUMAX+1,VALUE=X
  1.  S IDNTIFIR="",SCREEN=$G(SCREEN)
  1.  D FIND^DIC(FILE,IEN,FIELDS,FLAGS,VALUE,NUMBER,INDEX,SCREEN,IDNTIFIR,TROOT,MROOT)
  1.  Q
  1.  ;
  1. FMTOUT ;FMT output
  1.  N CHRT,DFN,GLB,I,NM,OUT,SSN
  1.  S GLB=BGUROOT_","_BGUQT_"DILIST"_BGUQT_")",OUT="RESULT",BGUCTR=0
  1.  S I=0 F  S I=$O(@GLB@(2,I)) Q:I=""  D
  1.  . S DFN=@GLB@(2,I),NM=@GLB@("ID",I,".01")
  1.  . S VAL=^DPT(DFN,0),Y=$P(VAL,U,3) X ^DD("DD")
  1.  . S SSN=$P(VAL,U,9)
  1.  . S HRCN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
  1.  . S BGUCTR=BGUCTR+1,@OUT@(BGUCTR)=NM_U_DFN_U_Y_U_SSN_U_HRCN
  1.  S @OUT@(0.01)=BGUCTR
  1.  ;I BGUCTR>BGUMAX S @OUT@(BGUMAX+1)="..MORE^"_$G(@OUT@(BGUMAX+1))
  1.  S BGUSTRT=""
  1.  I BGUCTR>BGUMAX X $G(BGUNX) S @OUT@(BGUMAX+1)="..MORE^"_BGUSTRT
  1.  E  S @OUT@(BGUCTR+1)="**END**"
  1.  Q
  1.  ; 
  1. LSTNM ;Partial last name search
  1.  S %=$O(^DPT("B",X),-1),BGUCOUNT=1
  1.  F I=1:1 S %=$O(^DPT("B",%)) Q:BGUCOUNT>BGUMAX!(%="")!(%'[X)  D
  1.  . F DFN=0:0 S DFN=$O(^DPT("B",%,DFN)) Q:'DFN  D
  1.  . . I $G(^DPT(DFN,0))'="" S VAL=^DPT(DFN,0),Y=$P(VAL,U,3) X ^DD("DD") S BGUCOUNT=BGUCOUNT+1,RESULT(I)=%_U_DFN_U_Y_U_$P(VAL,"^",9)_U_$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
  1.  S:BGUCOUNT>BGUMAX&($L(%)) RESULT(I)="..MORE^"_%
  1.  S:%="" RESULT(I)="**END**"
  1.  S RESULT(0.01)=BGUCOUNT
  1.  Q
  1. KILL ;
  1.  K @TROOT,@MROOT
  1.  K %,BGUAGEG,BGUBYR,BGUCOUNT,BGUD,BGUDFN,BGUEYR,BGUINC,BGUJ,BGUMAX
  1.  K BGUOBJ,BGUOBJN,BGUOBJV,BGUPARM,BGUQTR,BGURTN,BGUYQ,BGUYR
  1.  K BGUCTR,FIELDS,FILE,FLAGS,FROM,GLB,I,IDNTIFIR,IEN,INDEX
  1.  K NM,NUMBER,OUT,PART,BGUQT,BGUROOT,SCREEN,SSN,TROOT,VAL
  1.  K X1,X2,BGUZROS
  1.  Q
  1.  ;
  1. ZZZ ;