LRVER5 ;DALOI/CJS/DALOI/FHS - LAB ROUTINE DATA VERIFICATION ; 17-Oct-2014 09:22 ; MKK
;;5.2;LAB SERVICE;**42,153,283,286,1027,1034**;NOV 01, 1997;Build 88
;
I $G(LRNDISP) D
. S LRNX=0
. N LRX F S LRNX=$O(LRORD(LRNX)) Q:LRNX<1 S LRX(LRORD(LRNX))=""
. S LRX=0 F S LRX=$O(LRSB(LRX)) Q:LRX<1 K:'$D(LRX(LRX)) LRSB(LRX),LRSA(LRX)
;
; Check for amended results that have arrived via an HL7 interface.
; Only allow amended results to be verified during this session.
I $D(^LAH("LA7 AMENDED RESULTS",LRUID)) D
. S LRNX=0
. F S LRNX=$O(LRORD(LRNX)) Q:'LRNX I '$D(^LAH("LA7 AMENDED RESULTS",LRUID,LRORD(LRNX))) K LRORD(LRNX)
. S LRNX=0
. F S LRNX=$O(LRSB(LRNX)) Q:'LRNX I '$D(^LAH("LA7 AMENDED RESULTS",LRUID,LRNX)) K LRSB(LRNX),LRSA(LRNX)
;
S LRNX=0,LRVRM=12
;
V40 S LRNX=$O(LRORD(LRNX)) G V44:LRNX<1 D LRSUBS
;
; Check if changing performing lab.
I $P($G(LRSB(LRSB)),"^",9),'$$PLOK^LRVERA($P(LRSB(LRSB),"^",9),$G(LRDUZ(2)),DUZ(2),LRTS) G V40
;
D V25
;
V42 ;
;
S (LRDL,SX,X)=$P($G(LRSB(LRSB)),U),LRDVF=0,LREDIT=0
S:X=""&(LRDV'="") X=LRDV,LRDVF=1 ; default value
S LRTEST=$P(^LAB(60,LRTS,0),U)
K LRNOVER(LRSB)
;
Q42 ;
;
; Check for amended results that have arrived via an HL7 interface.
; I $D(^LAH("LA7 AMENDED RESULTS",LRUID,LRSB)) D G:SX'=X!($G(LRAMEND(LRSB))) V45
I $D(^LAH("LA7 AMENDED RESULTS",+$G(LRUID),LRSB)) D G:SX'=X!($G(LRAMEND(LRSB))) V45 ; IHS/OIT/MKK - LR*5.2*1034
. W !,LRTEST," " W:X'="" @LRFP
. D AMEND Q:$G(LRAMEND(LRSB))
. I SX=X W !,LRTEST," " W:X'="" @LRFP
;
; If entering results from a reference lab and not using normal/units
; from file #60 then ask user for these values otherwise display
; current file #60 values.
I $G(LRDUZ(2)),LRDUZ(2)'=DUZ(2) D
. I $G(^LAB(60,+LRTS,1,+$G(LRSPEC),.1)) D Q
. . D V25
. . W !!,"Current Ref Range: ",LRNG2,"-",LRNG3," Units: ",$P(LRNG,"^",7)
. . I LRNG4="",LRNG5="" Q
. . W !," Critical Low: ",LRNG4," Critical High: ",LRNG5
. N LRX,LRY
. D ASKPLNR,NORM
. S LRX=$P(LRNGS,"^",2,5),LRX=$TR(LRX,"^","!")
. S LRY=$P($G(LRSB(LRSB)),"^",5),$P(LRY,"!",2,5)=LRX
. S $P(LRSB(LRSB),"^",5)=LRY
;
W !,LRTEST," " W:X'="" @LRFP
R "//",X:DTIME
I X'?.ANP W $C(7)," No Control Characters allowed." G V42
S:$L($G(SX))&(X="") X=SX,LRDVF=1
S LRDL=X I X=""&LRDVF S (LRD,X)=LRDV G V45
Q43 G V40:X="",V45:X'["^",V44:X="^",LROUT:X="^^"
;
V43 S X=$P(X,U,2),DIC="^LAB(60,",DIC(0)="EOQZ" D ^DIC G:Y<1 Q42
S LRPLOC=$P(Y(0),U,5),LRSSQ=$P(LRPLOC,";",1),LRSB=$P(LRPLOC,";",2),LRTS=+Y
I LRSSQ="" W !,"Not in this group" G LROUT
I LRSS'=LRSSQ!'$D(^TMP("LR",$J,"TMP",LRSB)) W !,"Not in this group" G LROUT
S LRNX=0
F S LRNX=$O(LRORD(LRNX)) Q:LRNX<1 Q:LRSB=LRORD(LRNX)
I LRNX,LRSB=LRORD(LRNX) D LRSUBS,V25 G V42
;
V44 K SX
D COM^LRVER4
S LRNUF=1 S:LRVF LRSA=1
Q
;
V45 ;
K LRSKIP
I X="@" D G V46
. K:'$G(LRVF) ^LR(LRDFN,LRSS,LRIDT,LRSB)
. S X=$S($G(LRVF)&($D(LRSB(LRSB)))&('$D(LRM(LRSB))):"comment",$D(LRM(LRSB)):"pending",$D(LRSA(LRSB)):"canc",1:"")
. S $P(LRSB(LRSB),"^")=X,$P(LRSB(LRSB),"^",2)=""
;
S LRXD=U_$P(^LAB(60,LRTS,0),U,12),LRXDP=LRXD_"0)",LRXDP=@LRXDP
X:'(X="*"!($E(X)="?")!(X="C")!(X="#")!(X="canc")!(X="pending")) $P(LRXDP,U,5,99)
I '$D(X)#2 D HELP G V42
I $D(X)#2,X["?" D HELP G:'($P(LRXDP,U,2)["S") V42
I $D(X)#2,$P(LRXDP,U,2)["S",X'="*",X'="#",X'="canc",X'="pending" D LRSET G:'$D(X)#2 V42
I $D(X)#2,X="C",$P(LRXDP,U,2)'["S" D COMP G V42
;
V46 ;
G V42:'$D(X)#2
I LRVF,$D(LRSB(LRSB)),$D(LRSA(LRSB)) S LRSA(LRSB,1)=LRTEST
S X1=$S($D(^LR(LRDFN,LRSS,+LRLDT,LRSB)):$P(^(LRSB),U),1:"")
S:X="*" X="canc" S:X="#" X="comment"
;
I '$G(LRAMEND(LRSB)) S LRFLG=""
S Y=0 X:LRDEL'="" LRDEL
I '$G(LRAMEND(LRSB)) D RANGE^LRVER4
;
S:$P(X,U)="" $P(LRSB(LRSB),U)=""
I $P(X,U)'="" D
. S $P(LRSB(LRSB),U)=X,$P(LRSB(LRSB),U,2)=LRFLG
. S LRX=$$TMPSB^LRVER1(LRSB),LRY=$P(LRSB(LRSB),U,3)
. F I=1:1:$L(LRX,"!") I $P(LRY,"!",I)="" S $P(LRY,"!",I)=$P(LRX,"!",I)
. S $P(LRSB(LRSB),U,3)=LRY
. I $P($P(LRSB(LRSB),U,3),"!")="" D RONLT^LRVER3
. D
. . I '$D(LRSA(LRSB))#2 D Q
. . . S $P(LRSB(LRSB),U,4)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ))
. . . S $P(LRSB(LRSB),U,9)=$S($G(LRDUZ(2)):LRDUZ(2),1:$G(DUZ(2)))
. . S:'$P(LRSB(LRSB),U,4) $P(LRSB(LRSB),U,4)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ))
. S $P(LRSB(LRSB),U,5)=$TR(LRNGS,U,"!")
. S $P(LRSB(LRSB),U,9)=$S($G(LRDUZ(2)):LRDUZ(2),1:$G(DUZ(2)))
G:$D(LRNUF) V44 K LRNUF G V40:'$D(LRSKIP) S X=LRSKIP G Q43:X["^",V40
;
;
RANGE ;
S $P(LRSB(LRSB),"^")=X
; If previous results from another laboratory then use normals and units
; associated with those results.
D
. I $G(LRDUZ(2)),DUZ(2)'=LRDUZ(2) D PLNR^LRVR4 Q
. I $P(LRSB(LRSB),"^",9),DUZ(2)'=$P(LRSB(LRSB),"^",9) D PLNR^LRVR4
D RANGE^LRVER4
Q
;
;
LRSUBS ; From LRVR5
S LRSB=LRORD(LRNX),LRTS=$S($D(^TMP("LR",$J,"TMP",LRSB))#2:^(LRSB),1:0)
Q
;
;
LRSET ; from above and LRVR5
D ENTRYAUD^BLRUTIL("LRSET^LRVER5 0.0")
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
; LRSB may be null if LRSET is called from Executable Help
; of a Field Definition. The following line is from VA Patch
; LR*5.2*350 version of the routine. That is the LEDI IV patch.
I $G(LRSB)<1 N LRSB S LRSB=+$G(^LAB(60,+$G(DA(1)),.2))
; ----- END IHS/MSC/MKK - LR*5.2*1034
;
N I,LRERR,RESULT
D CHK^DIE(63.04,LRSB,"EH",X,.RESULT,"LRERR")
;
I RESULT'="^" S X=RESULT W " ",RESULT(0)
;
I RESULT="^" D
. F I=1:1:LRERR("DIHELP") W !,LRERR("DIHELP",I)
. K X
;
Q
;
;
COMP ; from LRVR5
S X="^%ET",@^%ZOSF("TRAP")
R !,"Enter your computation: ",C:DTIME
Q:"^"[C G CH:C="?"!(C["""") S C=$P(C," ",1)
S X="TRAP^LRVER5",@^%ZOSF("TRAP") D ^DIM S X="W "_C
I '$D(X)#2 W !,"Something's wrong with the syntax." G CH
F I=1:1:$L(C) I $E(C,I)?1A S I=.9 Q
G CH:I=.9,CH:C["/0",CH:C["\0" W !," equals ",@C G COMP
TRAP ;
W !!,"Error in your mathematical formular ",!
CH W !,"Enter for example: 5*2/4+1 and 3.5 will be returned [i.e. ((5*2)/4)+1=3.5]"
G COMP
;
;
V25 ; From LRVER4
N LRTX,LRX
S (LRDV,LRNG,LRDEL,LRNGS)=""
I '$D(^LAB(60,+LRTS,0))#2 Q
S LRX=+$P($P(^LAB(60,+LRTS,0),U,5),";",2)
S LRTX=$S($L($P(^LAB(60,+LRTS,0),U,5)):$O(^LAB(60,"C",$P(^LAB(60,+LRTS,0),U,5),0)),1:+LRTS)
S LRFP=$P(^LAB(60,LRTX,.1),U,3)
I LRFP="" S LRFP="$J(X,8)"
;
; Normal ranges, units, delta checks and default value
I $D(^LAB(60,LRTX,1,+$G(LRSPEC),0)) D
. S LRNG=^LAB(60,LRTX,1,+$G(LRSPEC),0)
. S LRDEL=$G(^LAB(62.1,+$P(LRNG,U,8),1))
. S LRDEL(1)=$G(^LAB(62.1,+$P(LRNG,U,8),2),"Q")
. S X2=$P(LRNG,U,9)
. S LRDV=$S('$D(LRSB(LRX)):$P(LRNG,U,10),1:"")
;
; When entering results from a reference lab check if flag to use normals/units from file 60.
I $G(LRDUZ(2)),LRDUZ(2)'=DUZ(2),'$G(^LAB(60,LRTX,1,+$G(LRSPEC),.1)) D PLNR^LRVR4
;
NORM ;
I $G(SEX)="" S SEX="M"
I $G(AGE)="" S AGE=99
S LRNGS=LRNG
F LRX=2:1:5 D
. N LRY
. S LRY=$P(LRNG,"^",LRX)
. ; enclose in quotes if text or structured numeric
. I LRY'="",$E(LRY)?.(1A,1"<",1">") S LRY=$C(34)_LRY_$C(34)
. I LRY'="",$E(LRY)'=$C(34),LRY'?.N.1".".N S @("LRY"_"="_LRY)
. S $P(LRNG,"^",LRX)=LRY,$P(LRNGS,"^",LRX)=LRY,@("LRNG"_LRX)=LRY
Q
;
;
LROUT ;
K SX
S LROUT=1
Q
;
;
HELP W !," ??",$C(7) S LRXDH=LRXD_"3)"
W:$D(@LRXDH) " ",@LRXDH
W !,"Enter * to report ""canc"" for canceled."
W !,"Enter # to report ""comment""."
W:'($P(LRXDP,U,2)["S") !,"Enter C to enter calculate mode."
Q
;
;
AMEND ; Process amended results and prompt user
N LRANS,LRLL,LRSQ,LRROOT,LRX
; flag to indicate if amended results have been extracted from LAH
S LRAMEND=0
; save current value of X
S LRX=X
S LRROOT=$Q(^LAH("LA7 AMENDED RESULTS",LRUID,LRSB))
I LRROOT="" Q
I $QS(LRROOT,1)'="LA7 AMENDED RESULTS"!($QS(LRROOT,2)'=LRUID)!($QS(LRROOT,3)'=LRSB) Q
S LRLL=$QS(LRROOT,4),LRSQ=$QS(LRROOT,5)
S LRPROF=+$O(^LRO(68.2,LRLL,10,0)) ; IHS/OIT/MKK -- LR*5.2*1027
I $D(^LAH(LRLL,1,LRSQ,LRSB)) D
. N DIR,DIRUT,DTOUT,DUOUT,LRJ,LRY,X,Y
. S LRY=^LAH(LRLL,1,LRSQ,LRSB)
. S DIR(0)="SOA^0:No;1:Yes;2:Keep but do not process",DIR("B")="Yes"
. S DIR("A",1)=" ",DIR("A",2)="Amended result: "_$P(LRY,"^")
. S DIR("A",2)=DIR("A",2)_" flag: "_$S($P(LRY,"^",2)'="":$P(LRY,"^",2),1:"None")
. S DIR("A",2)=DIR("A",2)_" units: "_$P($P(LRY,"^",5),"!",7)
. S DIR("A")="Accept amended results: "
. S DIR("?",1)="Answer with 0-No to not accept amended result and delete.",DIR("?",2)="1-Yes to process amended result.",DIR("?")="or 2-Keep which skips processing but leaves result for future processing."
. D ^DIR
. I $D(DIRUT) Q
. S LRANS=Y
. I LRANS=2 Q
. I LRANS=1 D
. . S LRX=$P(LRY,"^"),LRFLG=$P(LRY,"^",2),LRSB(LRSB)=LRY,LRJ=$P(LRY,"^",5)
. . F LRI=1,2,3,4,5,7,11,12 S $P(LRNG,"^",LRI)=$P(LRJ,"!",LRI)
. . S LRNGS=LRNG,(LRAMEND,LRAMEND(LRSB))=1
. . D LRSBCOM^LRVR4 ; also process any comments
. K ^LAH(LRLL,1,LRSQ,LRSB)
. K ^LAH("LA7 AMENDED RESULTS",LRUID,LRSB,LRLL,LRSQ)
. I +$O(^LAH(LRLL,1,LRSQ,1))<1 D ZAPALL^LRVR3(LRLL,LRSQ)
S X=LRX
Q
;
;
ASKPLNR ; Ask user for performing lab normal ranges and units when entering
; manually and not using values from file #60.
N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRI,LRJ,LRX,LRY,Y,X,Y
;
S LRX=$P($G(LRSB(LRSB)),"^",5)
;
W !!,"For test ",LRTEST
S DIR(0)="60.01,6"
I $P(LRX,"!",7)'="" S DIR("B")=$P(LRX,"!",7)
D ^DIR
I $D(DTOUT)!($D(DUOUT)) Q
; Set units into component 7 of piece 5
S $P(LRX,"!",7)=Y,$P(LRSB(LRSB),"^",5)=LRX
;
; Ask normals - high/low and critical
K DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
F LRJ=1,2,3,4 D Q:$D(DTOUT)!($D(DUOUT))
. K DIR
. S DIR(0)="60.01,"_LRJ,LRI=LRJ+1
. I $P(LRX,"!",LRI)'="" D
. . S DIR("B")=$P(LRX,"!",LRI)
. . I $E(DIR("B"))=$C(34) Q
. . I DIR("B")'?.N.1".".N S DIR("B")=$C(34)_DIR("B")_$C(34) ; enclose in quotes if text
. D ^DIR
. I $D(DTOUT)!($D(DUOUT)) Q
. S $P(LRX,"!",LRI)=Y
;
; Ask user for normality in case user does not know high/low/critical.
S LRRFLAG(LRSB)=$$RFLAG^LRVERA($P($G(LRSB(LRSB)),"^",2))
;
; Update normal variable LRNG
I $P(LRX,"!")="" S $P(LRX,"!")=LRSPEC
F LRI=1,2,3,4,5,7 S $P(LRNG,"^",LRI)=$P(LRX,"!",LRI)
;
Q
LRVER5 ;DALOI/CJS/DALOI/FHS - LAB ROUTINE DATA VERIFICATION ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**42,153,283,286,1027,1034**;NOV 01, 1997;Build 88
+2 ;
+3 IF $GET(LRNDISP)
Begin DoDot:1
+4 SET LRNX=0
+5 NEW LRX
FOR
SET LRNX=$ORDER(LRORD(LRNX))
IF LRNX<1
QUIT
SET LRX(LRORD(LRNX))=""
+6 SET LRX=0
FOR
SET LRX=$ORDER(LRSB(LRX))
IF LRX<1
QUIT
IF '$DATA(LRX(LRX))
KILL LRSB(LRX),LRSA(LRX)
End DoDot:1
+7 ;
+8 ; Check for amended results that have arrived via an HL7 interface.
+9 ; Only allow amended results to be verified during this session.
+10 IF $DATA(^LAH("LA7 AMENDED RESULTS",LRUID))
Begin DoDot:1
+11 SET LRNX=0
+12 FOR
SET LRNX=$ORDER(LRORD(LRNX))
IF 'LRNX
QUIT
IF '$DATA(^LAH("LA7 AMENDED RESULTS",LRUID,LRORD(LRNX)))
KILL LRORD(LRNX)
+13 SET LRNX=0
+14 FOR
SET LRNX=$ORDER(LRSB(LRNX))
IF 'LRNX
QUIT
IF '$DATA(^LAH("LA7 AMENDED RESULTS",LRUID,LRNX))
KILL LRSB(LRNX),LRSA(LRNX)
End DoDot:1
+15 ;
+16 SET LRNX=0
SET LRVRM=12
+17 ;
V40 SET LRNX=$ORDER(LRORD(LRNX))
IF LRNX<1
GOTO V44
DO LRSUBS
+1 ;
+2 ; Check if changing performing lab.
+3 IF $PIECE($GET(LRSB(LRSB)),"^",9)
IF '$$PLOK^LRVERA($PIECE(LRSB(LRSB),"^",9),$GET(LRDUZ(2)),DUZ(2),LRTS)
GOTO V40
+4 ;
+5 DO V25
+6 ;
V42 ;
+1 ;
+2 SET (LRDL,SX,X)=$PIECE($GET(LRSB(LRSB)),U)
SET LRDVF=0
SET LREDIT=0
+3 ; default value
IF X=""&(LRDV'="")
SET X=LRDV
SET LRDVF=1
+4 SET LRTEST=$PIECE(^LAB(60,LRTS,0),U)
+5 KILL LRNOVER(LRSB)
+6 ;
Q42 ;
+1 ;
+2 ; Check for amended results that have arrived via an HL7 interface.
+3 ; I $D(^LAH("LA7 AMENDED RESULTS",LRUID,LRSB)) D G:SX'=X!($G(LRAMEND(LRSB))) V45
+4 ; IHS/OIT/MKK - LR*5.2*1034
IF $DATA(^LAH("LA7 AMENDED RESULTS",+$GET(LRUID),LRSB))
Begin DoDot:1
+5 WRITE !,LRTEST," "
IF X'=""
WRITE @LRFP
+6 DO AMEND
IF $GET(LRAMEND(LRSB))
QUIT
+7 IF SX=X
WRITE !,LRTEST," "
IF X'=""
WRITE @LRFP
End DoDot:1
IF SX'=X!($GET(LRAMEND(LRSB)))
GOTO V45
+8 ;
+9 ; If entering results from a reference lab and not using normal/units
+10 ; from file #60 then ask user for these values otherwise display
+11 ; current file #60 values.
+12 IF $GET(LRDUZ(2))
IF LRDUZ(2)'=DUZ(2)
Begin DoDot:1
+13 IF $GET(^LAB(60,+LRTS,1,+$GET(LRSPEC),.1))
Begin DoDot:2
+14 DO V25
+15 WRITE !!,"Current Ref Range: ",LRNG2,"-",LRNG3," Units: ",$PIECE(LRNG,"^",7)
+16 IF LRNG4=""
IF LRNG5=""
QUIT
+17 WRITE !," Critical Low: ",LRNG4," Critical High: ",LRNG5
End DoDot:2
QUIT
+18 NEW LRX,LRY
+19 DO ASKPLNR
DO NORM
+20 SET LRX=$PIECE(LRNGS,"^",2,5)
SET LRX=$TRANSLATE(LRX,"^","!")
+21 SET LRY=$PIECE($GET(LRSB(LRSB)),"^",5)
SET $PIECE(LRY,"!",2,5)=LRX
+22 SET $PIECE(LRSB(LRSB),"^",5)=LRY
End DoDot:1
+23 ;
+24 WRITE !,LRTEST," "
IF X'=""
WRITE @LRFP
+25 READ "//",X:DTIME
+26 IF X'?.ANP
WRITE $CHAR(7)," No Control Characters allowed."
GOTO V42
+27 IF $LENGTH($GET(SX))&(X="")
SET X=SX
SET LRDVF=1
+28 SET LRDL=X
IF X=""&LRDVF
SET (LRD,X)=LRDV
GOTO V45
Q43 IF X=""
GOTO V40
IF X'["^"
GOTO V45
IF X="^"
GOTO V44
IF X="^^"
GOTO LROUT
+1 ;
V43 SET X=$PIECE(X,U,2)
SET DIC="^LAB(60,"
SET DIC(0)="EOQZ"
DO ^DIC
IF Y<1
GOTO Q42
+1 SET LRPLOC=$PIECE(Y(0),U,5)
SET LRSSQ=$PIECE(LRPLOC,";",1)
SET LRSB=$PIECE(LRPLOC,";",2)
SET LRTS=+Y
+2 IF LRSSQ=""
WRITE !,"Not in this group"
GOTO LROUT
+3 IF LRSS'=LRSSQ!'$DATA(^TMP("LR",$JOB,"TMP",LRSB))
WRITE !,"Not in this group"
GOTO LROUT
+4 SET LRNX=0
+5 FOR
SET LRNX=$ORDER(LRORD(LRNX))
IF LRNX<1
QUIT
IF LRSB=LRORD(LRNX)
QUIT
+6 IF LRNX
IF LRSB=LRORD(LRNX)
DO LRSUBS
DO V25
GOTO V42
+7 ;
V44 KILL SX
+1 DO COM^LRVER4
+2 SET LRNUF=1
IF LRVF
SET LRSA=1
+3 QUIT
+4 ;
V45 ;
+1 KILL LRSKIP
+2 IF X="@"
Begin DoDot:1
+3 IF '$GET(LRVF)
KILL ^LR(LRDFN,LRSS,LRIDT,LRSB)
+4 SET X=$SELECT($GET(LRVF)&($DATA(LRSB(LRSB)))&('$DATA(LRM(LRSB))):"comment",$DATA(LRM(LRSB)):"pending",$DATA(LRSA(LRSB)):"canc",1:"")
+5 SET $PIECE(LRSB(LRSB),"^")=X
SET $PIECE(LRSB(LRSB),"^",2)=""
End DoDot:1
GOTO V46
+6 ;
+7 SET LRXD=U_$PIECE(^LAB(60,LRTS,0),U,12)
SET LRXDP=LRXD_"0)"
SET LRXDP=@LRXDP
+8 IF '(X="*"!($EXTRACT(X)="?")!(X="C")!(X="#")!(X="canc")!(X="pending"))
XECUTE $PIECE(LRXDP,U,5,99)
+9 IF '$DATA(X)#2
DO HELP
GOTO V42
+10 IF $DATA(X)#2
IF X["?"
DO HELP
IF '($PIECE(LRXDP,U,2)["S")
GOTO V42
+11 IF $DATA(X)#2
IF $PIECE(LRXDP,U,2)["S"
IF X'="*"
IF X'="#"
IF X'="canc"
IF X'="pending"
DO LRSET
IF '$DATA(X)#2
GOTO V42
+12 IF $DATA(X)#2
IF X="C"
IF $PIECE(LRXDP,U,2)'["S"
DO COMP
GOTO V42
+13 ;
V46 ;
+1 IF '$DATA(X)#2
GOTO V42
+2 IF LRVF
IF $DATA(LRSB(LRSB))
IF $DATA(LRSA(LRSB))
SET LRSA(LRSB,1)=LRTEST
+3 SET X1=$SELECT($DATA(^LR(LRDFN,LRSS,+LRLDT,LRSB)):$PIECE(^(LRSB),U),1:"")
+4 IF X="*"
SET X="canc"
IF X="#"
SET X="comment"
+5 ;
+6 IF '$GET(LRAMEND(LRSB))
SET LRFLG=""
+7 SET Y=0
IF LRDEL'=""
XECUTE LRDEL
+8 IF '$GET(LRAMEND(LRSB))
DO RANGE^LRVER4
+9 ;
+10 IF $PIECE(X,U)=""
SET $PIECE(LRSB(LRSB),U)=""
+11 IF $PIECE(X,U)'=""
Begin DoDot:1
+12 SET $PIECE(LRSB(LRSB),U)=X
SET $PIECE(LRSB(LRSB),U,2)=LRFLG
+13 SET LRX=$$TMPSB^LRVER1(LRSB)
SET LRY=$PIECE(LRSB(LRSB),U,3)
+14 FOR I=1:1:$LENGTH(LRX,"!")
IF $PIECE(LRY,"!",I)=""
SET $PIECE(LRY,"!",I)=$PIECE(LRX,"!",I)
+15 SET $PIECE(LRSB(LRSB),U,3)=LRY
+16 IF $PIECE($PIECE(LRSB(LRSB),U,3),"!")=""
DO RONLT^LRVER3
+17 Begin DoDot:2
+18 IF '$DATA(LRSA(LRSB))#2
Begin DoDot:3
+19 SET $PIECE(LRSB(LRSB),U,4)=$SELECT($GET(LRDUZ):LRDUZ,1:$GET(DUZ))
+20 SET $PIECE(LRSB(LRSB),U,9)=$SELECT($GET(LRDUZ(2)):LRDUZ(2),1:$GET(DUZ(2)))
End DoDot:3
QUIT
+21 IF '$PIECE(LRSB(LRSB),U,4)
SET $PIECE(LRSB(LRSB),U,4)=$SELECT($GET(LRDUZ):LRDUZ,1:$GET(DUZ))
End DoDot:2
+22 SET $PIECE(LRSB(LRSB),U,5)=$TRANSLATE(LRNGS,U,"!")
+23 SET $PIECE(LRSB(LRSB),U,9)=$SELECT($GET(LRDUZ(2)):LRDUZ(2),1:$GET(DUZ(2)))
End DoDot:1
+24 IF $DATA(LRNUF)
GOTO V44
KILL LRNUF
IF '$DATA(LRSKIP)
GOTO V40
SET X=LRSKIP
IF X["^"
GOTO Q43
GOTO V40
+25 ;
+26 ;
RANGE ;
+1 SET $PIECE(LRSB(LRSB),"^")=X
+2 ; If previous results from another laboratory then use normals and units
+3 ; associated with those results.
+4 Begin DoDot:1
+5 IF $GET(LRDUZ(2))
IF DUZ(2)'=LRDUZ(2)
DO PLNR^LRVR4
QUIT
+6 IF $PIECE(LRSB(LRSB),"^",9)
IF DUZ(2)'=$PIECE(LRSB(LRSB),"^",9)
DO PLNR^LRVR4
End DoDot:1
+7 DO RANGE^LRVER4
+8 QUIT
+9 ;
+10 ;
LRSUBS ; From LRVR5
+1 SET LRSB=LRORD(LRNX)
SET LRTS=$SELECT($DATA(^TMP("LR",$JOB,"TMP",LRSB))#2:^(LRSB),1:0)
+2 QUIT
+3 ;
+4 ;
LRSET ; from above and LRVR5
+1 DO ENTRYAUD^BLRUTIL("LRSET^LRVER5 0.0")
+2 ;
+3 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+4 ; LRSB may be null if LRSET is called from Executable Help
+5 ; of a Field Definition. The following line is from VA Patch
+6 ; LR*5.2*350 version of the routine. That is the LEDI IV patch.
+7 IF $GET(LRSB)<1
NEW LRSB
SET LRSB=+$GET(^LAB(60,+$GET(DA(1)),.2))
+8 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+9 ;
+10 NEW I,LRERR,RESULT
+11 DO CHK^DIE(63.04,LRSB,"EH",X,.RESULT,"LRERR")
+12 ;
+13 IF RESULT'="^"
SET X=RESULT
WRITE " ",RESULT(0)
+14 ;
+15 IF RESULT="^"
Begin DoDot:1
+16 FOR I=1:1:LRERR("DIHELP")
WRITE !,LRERR("DIHELP",I)
+17 KILL X
End DoDot:1
+18 ;
+19 QUIT
+20 ;
+21 ;
COMP ; from LRVR5
+1 SET X="^%ET"
SET @^%ZOSF("TRAP")
+2 READ !,"Enter your computation: ",C:DTIME
+3 IF "^"[C
QUIT
IF C="?"!(C["""")
GOTO CH
SET C=$PIECE(C," ",1)
+4 SET X="TRAP^LRVER5"
SET @^%ZOSF("TRAP")
DO ^DIM
SET X="W "_C
+5 IF '$DATA(X)#2
WRITE !,"Something's wrong with the syntax."
GOTO CH
+6 FOR I=1:1:$LENGTH(C)
IF $EXTRACT(C,I)?1A
SET I=.9
QUIT
+7 IF I=.9
GOTO CH
IF C["/0"
GOTO CH
IF C["\0"
GOTO CH
WRITE !," equals ",@C
GOTO COMP
TRAP ;
+1 WRITE !!,"Error in your mathematical formular ",!
CH WRITE !,"Enter for example: 5*2/4+1 and 3.5 will be returned [i.e. ((5*2)/4)+1=3.5]"
+1 GOTO COMP
+2 ;
+3 ;
V25 ; From LRVER4
+1 NEW LRTX,LRX
+2 SET (LRDV,LRNG,LRDEL,LRNGS)=""
+3 IF '$DATA(^LAB(60,+LRTS,0))#2
QUIT
+4 SET LRX=+$PIECE($PIECE(^LAB(60,+LRTS,0),U,5),";",2)
+5 SET LRTX=$SELECT($LENGTH($PIECE(^LAB(60,+LRTS,0),U,5)):$ORDER(^LAB(60,"C",$PIECE(^LAB(60,+LRTS,0),U,5),0)),1:+LRTS)
+6 SET LRFP=$PIECE(^LAB(60,LRTX,.1),U,3)
+7 IF LRFP=""
SET LRFP="$J(X,8)"
+8 ;
+9 ; Normal ranges, units, delta checks and default value
+10 IF $DATA(^LAB(60,LRTX,1,+$GET(LRSPEC),0))
Begin DoDot:1
+11 SET LRNG=^LAB(60,LRTX,1,+$GET(LRSPEC),0)
+12 SET LRDEL=$GET(^LAB(62.1,+$PIECE(LRNG,U,8),1))
+13 SET LRDEL(1)=$GET(^LAB(62.1,+$PIECE(LRNG,U,8),2),"Q")
+14 SET X2=$PIECE(LRNG,U,9)
+15 SET LRDV=$SELECT('$DATA(LRSB(LRX)):$PIECE(LRNG,U,10),1:"")
End DoDot:1
+16 ;
+17 ; When entering results from a reference lab check if flag to use normals/units from file 60.
+18 IF $GET(LRDUZ(2))
IF LRDUZ(2)'=DUZ(2)
IF '$GET(^LAB(60,LRTX,1,+$GET(LRSPEC),.1))
DO PLNR^LRVR4
+19 ;
NORM ;
+1 IF $GET(SEX)=""
SET SEX="M"
+2 IF $GET(AGE)=""
SET AGE=99
+3 SET LRNGS=LRNG
+4 FOR LRX=2:1:5
Begin DoDot:1
+5 NEW LRY
+6 SET LRY=$PIECE(LRNG,"^",LRX)
+7 ; enclose in quotes if text or structured numeric
+8 IF LRY'=""
IF $EXTRACT(LRY)?.(1A,1"<",1">")
SET LRY=$CHAR(34)_LRY_$CHAR(34)
+9 IF LRY'=""
IF $EXTRACT(LRY)'=$CHAR(34)
IF LRY'?.N.1".".N
SET @("LRY"_"="_LRY)
+10 SET $PIECE(LRNG,"^",LRX)=LRY
SET $PIECE(LRNGS,"^",LRX)=LRY
SET @("LRNG"_LRX)=LRY
End DoDot:1
+11 QUIT
+12 ;
+13 ;
LROUT ;
+1 KILL SX
+2 SET LROUT=1
+3 QUIT
+4 ;
+5 ;
HELP WRITE !," ??",$CHAR(7)
SET LRXDH=LRXD_"3)"
+1 IF $DATA(@LRXDH)
WRITE " ",@LRXDH
+2 WRITE !,"Enter * to report ""canc"" for canceled."
+3 WRITE !,"Enter # to report ""comment""."
+4 IF '($PIECE(LRXDP,U,2)["S")
WRITE !,"Enter C to enter calculate mode."
+5 QUIT
+6 ;
+7 ;
AMEND ; Process amended results and prompt user
+1 NEW LRANS,LRLL,LRSQ,LRROOT,LRX
+2 ; flag to indicate if amended results have been extracted from LAH
+3 SET LRAMEND=0
+4 ; save current value of X
+5 SET LRX=X
+6 SET LRROOT=$QUERY(^LAH("LA7 AMENDED RESULTS",LRUID,LRSB))
+7 IF LRROOT=""
QUIT
+8 IF $QSUBSCRIPT(LRROOT,1)'="LA7 AMENDED RESULTS"!($QSUBSCRIPT(LRROOT,2)'=LRUID)!($QSUBSCRIPT(LRROOT,3)'=LRSB)
QUIT
+9 SET LRLL=$QSUBSCRIPT(LRROOT,4)
SET LRSQ=$QSUBSCRIPT(LRROOT,5)
+10 ; IHS/OIT/MKK -- LR*5.2*1027
SET LRPROF=+$ORDER(^LRO(68.2,LRLL,10,0))
+11 IF $DATA(^LAH(LRLL,1,LRSQ,LRSB))
Begin DoDot:1
+12 NEW DIR,DIRUT,DTOUT,DUOUT,LRJ,LRY,X,Y
+13 SET LRY=^LAH(LRLL,1,LRSQ,LRSB)
+14 SET DIR(0)="SOA^0:No;1:Yes;2:Keep but do not process"
SET DIR("B")="Yes"
+15 SET DIR("A",1)=" "
SET DIR("A",2)="Amended result: "_$PIECE(LRY,"^")
+16 SET DIR("A",2)=DIR("A",2)_" flag: "_$SELECT($PIECE(LRY,"^",2)'="":$PIECE(LRY,"^",2),1:"None")
+17 SET DIR("A",2)=DIR("A",2)_" units: "_$PIECE($PIECE(LRY,"^",5),"!",7)
+18 SET DIR("A")="Accept amended results: "
+19 SET DIR("?",1)="Answer with 0-No to not accept amended result and delete."
SET DIR("?",2)="1-Yes to process amended result."
SET DIR("?")="or 2-Keep which skips processing but leaves result for future processing."
+20 DO ^DIR
+21 IF $DATA(DIRUT)
QUIT
+22 SET LRANS=Y
+23 IF LRANS=2
QUIT
+24 IF LRANS=1
Begin DoDot:2
+25 SET LRX=$PIECE(LRY,"^")
SET LRFLG=$PIECE(LRY,"^",2)
SET LRSB(LRSB)=LRY
SET LRJ=$PIECE(LRY,"^",5)
+26 FOR LRI=1,2,3,4,5,7,11,12
SET $PIECE(LRNG,"^",LRI)=$PIECE(LRJ,"!",LRI)
+27 SET LRNGS=LRNG
SET (LRAMEND,LRAMEND(LRSB))=1
+28 ; also process any comments
DO LRSBCOM^LRVR4
End DoDot:2
+29 KILL ^LAH(LRLL,1,LRSQ,LRSB)
+30 KILL ^LAH("LA7 AMENDED RESULTS",LRUID,LRSB,LRLL,LRSQ)
+31 IF +$ORDER(^LAH(LRLL,1,LRSQ,1))<1
DO ZAPALL^LRVR3(LRLL,LRSQ)
End DoDot:1
+32 SET X=LRX
+33 QUIT
+34 ;
+35 ;
ASKPLNR ; Ask user for performing lab normal ranges and units when entering
+1 ; manually and not using values from file #60.
+2 NEW DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRI,LRJ,LRX,LRY,Y,X,Y
+3 ;
+4 SET LRX=$PIECE($GET(LRSB(LRSB)),"^",5)
+5 ;
+6 WRITE !!,"For test ",LRTEST
+7 SET DIR(0)="60.01,6"
+8 IF $PIECE(LRX,"!",7)'=""
SET DIR("B")=$PIECE(LRX,"!",7)
+9 DO ^DIR
+10 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+11 ; Set units into component 7 of piece 5
+12 SET $PIECE(LRX,"!",7)=Y
SET $PIECE(LRSB(LRSB),"^",5)=LRX
+13 ;
+14 ; Ask normals - high/low and critical
+15 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+16 FOR LRJ=1,2,3,4
Begin DoDot:1
+17 KILL DIR
+18 SET DIR(0)="60.01,"_LRJ
SET LRI=LRJ+1
+19 IF $PIECE(LRX,"!",LRI)'=""
Begin DoDot:2
+20 SET DIR("B")=$PIECE(LRX,"!",LRI)
+21 IF $EXTRACT(DIR("B"))=$CHAR(34)
QUIT
+22 ; enclose in quotes if text
IF DIR("B")'?.N.1".".N
SET DIR("B")=$CHAR(34)_DIR("B")_$CHAR(34)
End DoDot:2
+23 DO ^DIR
+24 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+25 SET $PIECE(LRX,"!",LRI)=Y
End DoDot:1
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+26 ;
+27 ; Ask user for normality in case user does not know high/low/critical.
+28 SET LRRFLAG(LRSB)=$$RFLAG^LRVERA($PIECE($GET(LRSB(LRSB)),"^",2))
+29 ;
+30 ; Update normal variable LRNG
+31 IF $PIECE(LRX,"!")=""
SET $PIECE(LRX,"!")=LRSPEC
+32 FOR LRI=1,2,3,4,5,7
SET $PIECE(LRNG,"^",LRI)=$PIECE(LRX,"!",LRI)
+33 ;
+34 QUIT
