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