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

AUPNLK.m

Go to the documentation of this file. 
  1. AUPNLK ; IHS/CMI/LAB - IHS PATIENT LOOKUP MAIN ROUTINE 24-MAY-1993 ; [ 03/16/2004  7:43 AM ]
  1.  ;;99.1;IHS DICTIONARIES (PATIENT);**5,6,9,10,12,13**;JUN 13, 2003;Build 9
  1.  ;patch 5 - fm v22
  1.  ;'Modified' MAS Patient Look-up Routine for ADT Version 3.6, June 1987
  1.  ; This routine will not be executed if DIC(0)["I" or caller
  1.  ; used IX^DIC.
  1.  ;
  1.  ; AUPQF values have the following meaning:
  1.  ;      0 = Initial state
  1.  ;      1 = Primary error
  1.  ;      2 = Operator/time out
  1.  ;      3 = Retry
  1.  ;      4 = Hit
  1.  ;      5 = Added patient
  1.  ;;EP;ENTERNAL ENTRY POINT
  1.  ;
  1. START ;
  1.  D ^AUPNLKI ;             Initialization
  1.  I AUPQF D EOJ Q
  1.  D FINDPAT ;              Find patient
  1.  D EOJ ;                  Cleanup
  1.  S:'$D(X) X=""
  1.  Q
  1.  ;
  1. FINDPAT ; FIND PATIENT
  1.  I DIC(0)'["A" S AUPX=X D CHKPAT D:AUPQF=4 HIT Q
  1.  F AUPL=0:0 S AUPQF=0 D ASKPAT D CHKPAT D:AUPQF=4 HIT Q:AUPQF'=3
  1.  Q
  1.  ;
  1. ASKPAT ;
  1.  K AUPCNT,AUPD,AUPIDS,AUPIFN,AUPIFNS,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNICK,AUPNPAT,AUPNSEX,AUPNUM,AUPS,AUPSEL,DTOUT,DUOUT  ; IHS/SD/EFG  AUPN*99.1*13  3/16/2004
  1.  ;N AUP,AUPBEG,AUPCNT,AUPDFN,AUPDIC,AUPDICS,AUPDICW,AUPI,AUPIFN,AUPIFNS,AUPIX,AUPL,AUPNICK,AUPNUM,AUPQF,AUPS,AUPSEL,AUPLP1,AUPMAPY  ; IHS/SD/EFG  AUPN*99.1*13  3/16/2004
  1.  S AUPX=""
  1.  ;W !!,$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ") I $D(DIC("B")),DIC("B")]"" W DIC("B"),"// " S AUPX=DIC("B")
  1.  ;D EN^DDIOL($S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: "),"","!!") I $D(DIC("B")),DIC("B")]"" D EN^DDIOL(DIC("B")_"// ") S AUPX=DIC("B")
  1.  NEW DSPVAL S DSPVAL=$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ")
  1.  I $D(DIC("B")),DIC("B")]"" S AUPX=DIC("B"),DSPVAL=DSPVAL_DIC("B")_"//"
  1.  D EN^DDIOL(DSPVAL)
  1.  R X:DTIME S:X["^" DUOUT=1 S:'$T DTOUT=1,X="^"
  1.  S:X]"" AUPX=X
  1.  Q
  1.  ;
  1. CHKPAT ;
  1.  K AUPIFNS,AUPS,AUPSEL
  1.  S AUPCNT=0
  1.  I AUPX=""!(AUPX["^") S AUPQF=2 Q
  1.  I AUPX["?" D ^AUPNLKH S AUPQF=3 Q
  1.  ;I AUPX?1A!(AUPX'?.ANP)!($L(AUPX)>30)!($E(AUPX)=",") W:DIC(0)["Q" *7," ??" S AUPQF=3 Q
  1.  I AUPX?1A!(AUPX'?.ANP)!($L(AUPX)>30)!($E(AUPX)=",") D:DIC(0)["Q"  S AUPQF=3 Q
  1.  .NEW % S %=$C(7)_"  ??" D EN^DDIOL(%)
  1.  I '$D(DIADD),AUPX'?1"""".E1"""" D LOOKUPS^AUPNLKB ; Find patient
  1.  Q:AUPQF  ; Quit if patient found
  1.  I DIC(0)["L" D ADDPAT^AUPNLKB ;  Try adding the patient
  1.  Q:AUPQF  ; Quit if add successful
  1.  ;W:DIC(0)["Q" *7," ??"
  1.  I DIC(0)["Q" D EN^DDIOL($C(7)_"  ??")
  1.  S AUPQF=3
  1.  Q
  1.  ;
  1. HIT ;
  1.  I DIC(0)["E" D WRT
  1.  Q:AUPQF'=4
  1.  I '$D(DICR),$T(SENS^DGSEC4)]"" S Y=+AUPDFN D ^DGSEC S AUPDFN=Y I Y<0 S AUPQF=3 Q  ;IHS/ANMC/LJF 9/1/2000
  1.  S AUPX=$P(AUPS(AUPDFN),U,2),AUPDFN=AUPDFN_U_$P(AUPS(AUPDFN),U)
  1.  N DA,X S DA=+AUPDFN X $P(^DD(2,.081,0),U,5,99) I X,DIC(0)["E" D DUPECHK
  1.  Q
  1.  ;
  1. WRT ;
  1.  I $P(@(AUPDIC_"0)"),U,2)["O"!('$D(AUPSEL)&($D(AUPNICK(AUPDFN)))) D WRT2
  1.  Q:AUPQF'=4
  1.  I '$D(AUPSEL),'$D(AUPNICK(AUPDFN)),$P($P(AUPS(AUPDFN),U,2),AUPX)="" D EN^DDIOL($E($P(AUPS(AUPDFN),U,2),$L(AUPX)+1,$L($P(AUPS(AUPDFN),U,2))))
  1.  D EN^DDIOL($S($D(AUPSEL)!($P(AUPS(AUPDFN),U)'=$P(AUPS(AUPDFN),U,2)):"  "_$P(AUPS(AUPDFN),U)_"  ",1:"  "))
  1.  S Y=+AUPDFN X:$D(^DPT(AUPDFN,0)) DIC("W")
  1.  Q
  1.  ;
  1. WRT2 ;
  1.  D EN^DDIOL("  "_$P(^DPT(AUPDFN,0),U)),EN^DDIOL("OK","","!?8")
  1.  S %=1 D YN^DICN
  1.  S:%'=1 AUPQF=3,AUPDFN=-1
  1.  K %,%Y
  1.  Q
  1.  ;
  1. DUPECHK ; SELECTED PATIENT HAS UNRESOLVED DUPES
  1.  I $D(^VA(15,"ALK","DPT(",+Y,2)) S AUPMT=$O(^(2,0)) D DUPECHK2 Q
  1.  ; Code to inform user of potential duplicates would go here.
  1.  Q
  1.  ;
  1. DUPECHK2 ; VERIFIED DUPE
  1.  D EN^DDIOL("The patient you have selected is a 'verified duplicate' of","","!?6")
  1.  D EN^DDIOL($P(^DPT(AUPMT,0),U),"","!?12") S AUPSY=Y,Y=AUPMT D SET^AUPNLKZ X DIC("W") S Y=AUPSY D RESET^AUPNLKZ
  1.  D EN^DDIOL("If you are adding data for this patient please reselect!","","!?6")
  1.  K AUPMT,AUPSY
  1.  Q
  1.  ;
  1. EOJ ;
  1.  K AUPNLK("ICN")
  1.  I AUPQF=1 S Y=-1 K AUPQF,AUPDIC,DIC("W") Q
  1.  I AUPQF=2!(AUPQF=3) S Y=-1,X=AUPX D KILL Q
  1.  S Y=AUPDFN,X=AUPX
  1.  D EOJ2
  1.  D KILL
  1.  Q
  1.  ;
  1. EOJ2 ;
  1.  ; - FOLLOW MERGE CHAIN  -
  1.  S AUPSY=Y
  1.  F AUPL=0:0 Q:'$P(^DPT(+Y,0),U,19)  S Y=$P(^(0),U,19),Y=Y_U_$P(^DPT(Y,0),U,1) ; Will abort if no ^DPT entry for Y
  1.  I DIC(0)["E",Y'=AUPSY D EN^DDIOL("You now have patient "_$P(^DPT(+Y,0),U),"","!?6")
  1.  K AUPSY
  1.  ; -- SPACE BAR AND Y(0) --
  1.  S:DIC(0)'["F" ^DISV($S($D(DUZ)#2:DUZ,1:0),"^DPT(")=+Y,^DISV($S($D(DUZ)#2:DUZ,1:0),"^AUPNPAT(")=+Y S:DIC(0)["Z" Y(0)=^DPT(+Y,0),Y(0,0)=$P(^(0),U,1)
  1.  ; -- RESET Y AND Y(0) FOR 9000001 LOOKUP --
  1.  I AUPDIC="^AUPNPAT(" S $P(Y,U,2)=+Y I DIC(0)["Z" S Y(0)=^AUPNPAT(+Y,0)
  1.  ; -- POST SELECTION --
  1.  X:$D(^DD(2,0,"ACT")) ^("ACT") X:$D(^DD(9000001,0,"ACT")) ^("ACT")
  1.  ; -- SET NAKED --
  1.  S:$D(AUPDIC) DIC=AUPDIC I $D(@(DIC_"+Y,0)"))
  1.  ; ----- -
  1.  Q
  1.  ;
  1. KILL ;
  1.  ; - RESTORE DIC AND DIC("S") -
  1.  S:$D(AUPDIC) DIC=AUPDIC
  1.  ;K DIC("S","IHSORIG"),DIC("S","IHSLOOK") K:$D(DIC("S"))<10 DIC("S") S:$D(AUPDICS) DIC("S")=AUPDICS
  1.  K AUPNORIG,AUPNLOOK K:$D(DIC("S"))<10 DIC("S") S:$D(AUPDICS) DIC("S")=AUPDICS ;IHS/ANMC/CLS 09/13/2000 fm v22
  1.  ; - - -
  1.  K D,DIC("W"),DO
  1.  D:$D(AUPNLK("ALL")) RESET^AUPNLKZ ; Undocumented feature
  1.  S AUPX=$S($D(AUPNLK("ALL")):1,1:0) K AUPNLK S:AUPX AUPNLK("ALL")=1
  1.  K AUP,AUPBEG,AUPCNT,AUPDFN,AUPDIC,AUPDICS,AUPDICW,AUPI,AUPIFN,AUPIFNS,AUPIX,AUPL,AUPNICK,AUPNUM,AUPQF,AUPS,AUPSEL,AUPX,AUPLP1,AUPMAPY  ; IHS/SD/EFG  AUPN*99.1*13  3/16/2004
  1.  Q