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

LRDPA.m

Go to the documentation of this file. 
  1. LRDPA ;SLC/RWF/WTY/KLL - FILE OF FILES LOOKUP ON ENTITIES ; 2/28/03 4:10pm
  1.  ;;5.2;LAB SERVICE;**137,1002,121,153,202,211,248,1018,305,1022,360,1031,435,1039**;NOV 1, 1997;Build 31
  1.  ;;5.2;LAB SERVICE;**137,121,153,202,211,248,305,360,435**;Sep 27, 1994;Build 1
  1.  ;
  1.  ;Reference to ^DIC( supported by IA #916
  1.  ;Reference to ^DIC("AC" supported by IA #511
  1.  ;Reference to ^ORD(100.99 supported by IA #2414
  1.  ;Reference to ^DIC supported by IA #10006
  1.  ;Reference to LK^ORX2 supported by IA #867
  1.  ;Reference to ULK^ORX2 supported by IA #867
  1.  ;Reference to $$DTIME^XUP supported by IA # -none available-
  1.  ;Reference to EN^DDIOL supported by IA #10142
  1.  ;
  1.  ;IF '$D(DIC) USE PATIENT FILE, ALLOW "FILE:NAME" EXTENDED SYNTAX
  1.  ;IF DIC=0 ASK FILE NAME, IF PATIENT FILE, USE DPA, 
  1.  ;  OTHERWISE ^DIC LOOK-UP
  1.  ;IF DIC=N^GLOBAL, LOOK-UP ON FILE N
  1.  ;RETURN (DFN,Y)=IFN, LRDPF=N^GLOBAL, '$D(DIC), LRDFN=IFN OF ^LR 
  1.  ; GLOBAL  PNM=NAME,SSN=SSN,SSN(1)=LAST4,SSN(2)=SSN WITHOUT '-'
  1.  ;ROUTINE SSN^LRU CONTROLS SSN FORMAT
  1.  ;ALSO WILL RETURN LRLABKY variable if not defined.
  1.  ;LRLOOKUP=1 blocks ability to add new entries (lookup only)
  1.  S:$G(LRREFFL) DIC="67^LRT(67"
  1.  G:$G(LRORDRR)="R" ^LRDPAREF
  1.  S X="",U="^",DTIME=$$DTIME^XUP(DUZ)
  1.  S DIC(0)=$S('$D(DIC(0)):"EMQZ",DIC(0)["A":"EMQZ",1:DIC(0))
  1.  S:DIC(0)'["Z" DIC(0)=DIC(0)_"Z"
  1.  K DLAYGO I '($D(DIC)[0),DIC'=0,'$P(DIC,"^") S DIC=0
  1. DPA ;from LRUPS
  1.  D:'$D(LRLABKY) LABKEY^LRPARAM
  1.  K VADM,VAIN,VA
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  K AGE,DOB,HRCN,SEX,SSN  ;IHS/ANMC/CLS 08/18/96
  1.  ;----- END IHS MODIFICATIONS
  1.  S LRDPF="" G ANY:'($D(DIC)[0)
  1.  R !,"Select Patient Name: ",X:DTIME
  1. DPA1 ;Entry point from PNAME^LRAPDA
  1.  I X'?1"%"9N.E,$L($P(X,"^",2))'=18,X=""!(X["^") S DFN=-1 K DLAYGO G END
  1.  ;The X'?1"%"9N.E was added since the VIC data stream contains a carat.
  1.  ;The $L($P(X,"^",2))'=18 was added for VHIC 4.0
  1.  I X="??" W !,"You may enter patient identification or enter a file name followed by "":"".",!,"You may enter ""?:?"" for more extended help." G DPA
  1. EN1 ;from LRUG, LRUPS
  1.  I X[":" S LRX=$P(X,":",2),X=$P(X,":",1),DIC=0 K:LRX="" LRX G ANY:X=""!(X["?") W !," File: ",X G FL
  1. EN ;
  1.  S:DIC(0)'["Z" DIC(0)=DIC(0)_"Z"
  1.  S DIC="^DPT(",LRDPF="2^DPT(",VA200=""
  1.  ; DLAYGO not allowed for DPT( on first pass
  1.  S DIC("S")="S:X?1""%""9N.E1""?"" X=$E(X,2,10) I 1"
  1.  ;The DIC("S") was added to preprocess any data from a VIC card. The VIC
  1.  ;card data has guard codes before and after the patient data. The SSN
  1.  ;is extracted if these guard codes exist. DIC("S") was added in several
  1.  ;places and in all instances it is being killed immediately after use.
  1.  ;
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  ;IHS DOES NOT WANT SSN TO BE AN IDENTIFIER
  1.  S DIC("W")=""
  1.  ;----- END IHS MODIFICATIONS
  1.  ;
  1.  D ^DIC K DIC("S"),DLAYGO K:Y>0 DUOUT
  1.  ;Since VIC card data contains carats, DUOUT will be returned whenever
  1.  ;the VIC card is used.  If the user ^'s out, Y will be equal to -1.
  1.  ;If Y is greater than 0 the data is valid and DUOUT should be ignored.
  1.  I Y<1 K DIC D LAYG G DPA
  1.  S DFN=+Y,PNM=$P(Y(0),"^") D PT^LRX D:DOD'="" WARN G END
  1.  ;
  1. LAYG ;Don't allow DLAYGO on second pass.
  1.  K DLAYGO S DIC(0)="EQMZ" Q
  1.  Q:'$P($G(LRPARAM),"^",6)
  1.  Q:'$D(LRLABKY)
  1.  S DLAYGO=2 S DIC(0)="EQMZL"
  1.  Q
  1. ANY S:DIC'=0 LRDPF=+DIC_^DIC(+DIC,0,"GL") G FL1:DIC'=0 D FILE
  1.  G NONE:Y=-1,FL0
  1.  ;
  1. FL S DIC="^DIC(",DIC(0)=$S(X]"":"EMQZ",1:"AEMQZ"),DIC("S")="I $D(^DIC(""AC"",""LR"",+Y))" D ^DIC G NONE:Y=-1
  1. FL0 S LRDPF=+Y_^DIC(+Y,0,"GL"),DIC=LRDPF I +$G(LRDPF)=2 K DIC G LRDPA
  1. FL1 ;
  1.  D:'$D(LRLABKY) LABKEY^LRPARAM
  1.  ;DLAYGO not allowed for DPT(
  1.  I +LRDPF'=2,'$G(LRLOOKUP) S DLAYGO=+LRDPF
  1.  S DIC="^"_$P(LRDPF,"^",2),DIC(0)=$S($D(LRX):"EMQZ",1:"AEMQZ")
  1.  I '$G(LRLOOKUP) D
  1.  .S DIC(0)=DIC(0)_$S(+LRDPF>60&(+LRDPF<70)&$D(LRLABKY):"L",+LRDPF>1000:"L",1:"")
  1.  .S:DIC(0)["L" DLAYGO=+LRDPF
  1.  S:$D(LRX) X=LRX K LRX,DIC("S")
  1.  I X["?" S DIC("S")="S:X?1""%""9N.E1""?"" X=$E(X,2,10) I 1" D ^DIC K DIC("S") K:Y>0 DUOUT S:DIC(0)'["A" DIC(0)=DIC(0)_"A"
  1.  W:DIC(0)'["A" "   Entry: ",X
  1.  S DIC("S")="S:X?1""%""9N.E1""?"" X=$E(X,2,10) I 1"
  1.  S:DIC="^LAB(62.3," DIC("S")=DIC("S")_" "_"I '$P(^LAB(62.3,Y,0),U,4)"
  1.  D ^DIC K DIC("S") G NONE:Y=-1 S DFN=+Y,PNM=$P(Y(0),"^") D PT^LRX
  1.  G END
  1. NONE S Y=-1,DFN=-1,LRDFN=-1,LRDPF="0^NULL("
  1.  K DIC,VAIN,VADM,VA S VA200="" Q
  1.  Q
  1. REASK S DFN=-1,DIC("S")="S:X?1""%""9N.E1""?"" X=$E(X,2,10) I 1",DIC(0)=DIC(0)_"A"
  1.  D ^DIC K:Y>0 DUOUT K DIC("S") G:Y<1 END S DFN=+Y,PNM=$P(Y(0),"^") D PT^LRX
  1. END ;from LROR, LRSETUP
  1.  S:'$D(DFN) DFN=-1 S Y=DFN
  1.  I DFN=-1 D  Q
  1.  .S LRDFN=-1 K DIC,DLAYGO S VA200=""
  1.  S X="^"_$P(LRDPF,"^",2)_Y_",""LR"")",LRDFN=+$S($D(@X):@X,1:-1)
  1.  G E3:LRDFN>0
  1.  L +^LR(0):5 I '$T D  Q
  1.  .S MSG="The LAB DATA file is locked.  Please try again later."
  1.  .D EN^DDIOL(MSG,"","!!") K MSG
  1.  .S (DFN,LRDFN)=-1,VA200=""
  1.  .K DIC,DLAYGO
  1.  S LRDFN=$P(^LR(0),"^",3)+1
  1.  I $D(@X) L -^LR(0) K DIC,DLAYGO G LRDPA
  1. E2 I $D(^LR(LRDFN)) S LRDFN=LRDFN+1 G E2
  1.  S ^LR(LRDFN,0)=LRDFN_"^"_+LRDPF_"^"_DFN,@X=LRDFN,^(0)=$P(^LR(0),"^",1,2)_"^"_LRDFN_"^"_(1+$P(^(0),"^",4)),^LR("B",LRDFN,LRDFN)="" L -^LR(0)
  1. E3 I '$D(^LR(LRDFN,0))#2 W !!,"Internal patient ID incorrect in ^LR( for ",PNM,".  Contact Lab Coordinator.",$C(7) S LRDFN=-1 Q
  1.  I LRDFN>0,$P(^LR(LRDFN,0),"^",2)'=+LRDPF!($P(^(0),"^",3)'=DFN) W !,$C(7),"Internal patient ID incorrect for ",PNM,".  Contact Lab Coordinator." S LRDFN=-1 Q
  1.  D INF^LRX
  1.  D ^LRDPA1:($D(LRDPAF)&(LRDFN>0)) K DIC,DLAYGO S VA200=""
  1.  I DFN,$P($G(^ORD(100.99,1,"CONV")),"^")=0 D EN^LR7OV2(DFN_";"_$P(LRDPF,"^",2),1)
  1.  Q
  1.  ;
  1. FILE I X'["?" W !,"Select FILE: " R X:DTIME I X["^"!(X="") S X="",Y=-1 Q
  1.  D DICQ:X["?" G FILE:X=""
  1.  S DIC="^DIC(",DIC(0)="EMQZ"
  1.  S DIC("S")="I $D(^DIC(""AC"",""LR"",+Y)),+Y'=44"
  1.  D ^DIC K DIC("S") I Y=-1 G FILE
  1.  Q
  1. DICQ ;
  1.  S DIC="^DIC(",DIC(0)="EQZ",D="AC",X="LR"
  1.  S DIC("S")="I +Y'=44"  D IX^DIC
  1.  I Y=-1 S X="" Q
  1.  S X=Y(0,0)
  1.  K D,DIC S Y=1
  1.  Q
  1. % R %:DTIME Q:%=""!(%["N")!(%["Y")  W !,"Answer 'Y' or 'N': " G %
  1.  ;
  1. EN2(DFN,LOCK,TALK) ;Patient Lock
  1.  ;TALK 1:write, 0:silent
  1.  ;LOCK 1:lock, 0:unlock
  1.  Q:'$G(DFN)
  1.  S:'$D(LOCK) LOCK=0 S:'$D(TALK) TALK=0
  1.  S X=DFN_";DPT("
  1.  I LOCK D LK^ORX2
  1.  I 'LOCK D ULK^ORX2
  1.  Q
  1. WARN ;Warn the user the patient has died and display date of death (LR*5.2*360)
  1.  S Y=DOD D DD^LRX
  1.  W !?10,@LRVIDO,"Patient ",PNM," died on: ",Y,@LRVIDOF,!
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Do you wish to continue with this patient [Yes/No]"
  1.  S DIR("T")=120
  1.  D ^DIR K DIR
  1.  I Y=0!($D(DIRUT)) S DFN=-1
  1.  K DIRUT
  1.  Q