LRVER5 ;DALOI/STAFF - LAB ROUTINE DATA VERIFICATION ;05/12/16 09:47
;;5.2;LAB SERVICE;**42,153,283,286,350,458,488**;Sep 27, 1994;Build 1
;
; ZEXCEPT is used to identify variables which are external to a specific TAG
; used in conjunction with Eclipse M-editor.
;
;
;ZEXCEPT: LRD,LRDL,LRDUZ,LRDV,LRDVF,LREDIT,LRFP,LRNDISP,LRNG,LRNG2,LRNG3,LRNG4,LRNG5,LRNGS,LRNOVER,LRNX,LRORD,LRSA,LRSB,LRSPEC,LRTEST,LRTS,LRUID,LRVRM,SX,X
;
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
; and if not then restore LRSB(LRSB) from LRSA if previous verified to avoid triggering change prompt.
;I $P($G(LRSB(LRSB)),"^",9),'$$PLOK^LRVERA($P(LRSB(LRSB),"^",9),$G(LRDUZ(2)),DUZ(2),LRTS) G V40
I $P($G(LRSB(LRSB)),"^",9),'$$PLOK^LRVERA($P(LRSB(LRSB),"^",9),$G(LRDUZ(2)),DUZ(2),LRTS) D Q
. I $D(LRSA(LRSB)) S LRSB(LRSB)=LRSA(LRSB)
;
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
. 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,NORM2
. 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
;
Q42A ;
W !,LRTEST," " W:X'="" @LRFP
R "//",X:DTIME
I X'?.ANP W $C(7)," No Control Characters allowed." S X=SX G Q42A
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 ;
;ZEXCEPT: DIC,LRNUF,LRNX,LRORD,LRPLOC,LRSA,LRSB,LRSS,LRSSQ,LRTS,SX,X,Y
;
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 ;
;
;ZEXCEPT: LRDFN,LRIDT,LRM,LRSA,LRSB,LRSKIP,LRSS,LRTS,LRVF,LRXD,LRXDP,SX,X
;
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)=""
;
; If user has LRDATA security and wants to edit units and reference ranges.
I X="~" D G Q42A
. N LRKEY
. D OWNSKEY^XUSRB(.LRKEY,"LRDATA")
. I LRKEY(0)=1 D EDITUNR
. S X=SX
;
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
I LRDEL'="" S LRQ=1 D XDELTACK^LRVERA K LRQ
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 ;
;
;ZEXCEPT: LRDUZ,LRSB,X
;
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
;
;ZEXCEPT: LRNX,LRORD,LRSB,LRTS
;
S LRSB=LRORD(LRNX),LRTS=$S($D(^TMP("LR",$J,"TMP",LRSB))#2:^(LRSB),1:0)
Q
;
;
LRSET ; from above and LRVR5
; Also called from Input Transform of file #60.01 field #9
;
;ZEXCEPT: DA,X
;
N DIERR,I,LRERR,LRESULT
;
; If called from EXECUTABLE HELP of file #60, field #9 then set LRSB from DD info.
I $G(LRSB)<1 N LRSB S LRSB=+$G(^LAB(60,+$G(DA(1)),.2))
;
D CHK^DIE(63.04,LRSB,"EH",X,.LRESULT,"LRERR")
I LRESULT'="^" D Q ;
. D EN^DDIOL(" "_LRESULT(0),"","$C(32)")
. S X=LRESULT
;
I LRESULT="^" D
. D MSG^DIALOG("WHB","","","","LRERR")
. K X
;
Q
;
;
COMP ; from LRVR5
;
;ZEXCEPT: C,I,X
;
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 ; Error trap for COMP subroutine above
W !!,"Error in your mathematical formula ",!
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, LRSTUF2
;
;ZEXCEPT: AGE,LRDEL,LRDUZ,LRDV,LRFP,LRNG,LRNGS,LRSA,LRSB,LRSPEC,LRTS,LRVF,N,SEX,X2
;
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 ;
;
; Use previously stored units/normals if editing previous verified results.
I $G(LRSB) D
. I $D(LRSA(LRSB)) D
. . I $P(LRSA(LRSB),"^")?1(1"pending",1"comment",1"canc") Q
. . S LRNG=$P(LRSA(LRSB),"^",5),LRNG=$TR(LRNG,"!","^")
;
D NORM2
;
Q
;
NORM2 ;
;
;ZEXCEPT: AGE,LRNG,LRNGS,LRX,SEX
;
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 ;
;
;ZEXCEPT: LROUT,SX
;
K SX
S LROUT=1
Q
;
;
HELP ; Display help prompt from test result entry.
;
;ZEXCEPT: LRXD,LRXDH
;
N LRKEY
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."
D OWNSKEY^XUSRB(.LRKEY,"LRDATA")
I LRKEY(0)=1 W !,"Enter ~ to edit units/reference ranges."
Q
;
;
EDITUNR ; Allow user to edit units and normal reference ranges.
;
;ZEXCEPT: LRNG,LRNGS,LRSB,LRSPEC,LRTS
;
N LRX,LRY,LRUNR
S LRUNR=0
I $D(^LAB(60,+LRTS,1,+$G(LRSPEC),0)) D
. N DIR,DIRUT,DTOUT,DUOUT,LRNNG,LRNNG2,LRNNG3,LRNNG4,LRNNG5,X,Y
. S LRNNG=^LAB(60,+LRTS,1,+$G(LRSPEC),0)
. F LRX=2:1:5 D
. . S LRY=$P(LRNNG,"^",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(LRNNG,"^",LRX)=LRY,@("LRNNG"_LRX)=LRY
. W !
. S DIR("A",1)="Current Laboratory Test File Values"
. S DIR("A",2)="Current Ref Range: "_LRNNG2_"-"_LRNNG3_" Units: "_$P(LRNNG,"^",7)
. I LRNNG4="",LRNNG5=""
. E S DIR("A",3)=" Critical Low: "_LRNNG4_" Critical High: "_LRNNG5
. S DIR(0)="YO",DIR("A")="Use these values",DIR("B")="NO"
. D ^DIR
. I Y'=1 S LRUNR=1 Q
. S LRX=$P(LRNNG,"^",2,5),LRX=$TR(LRX,"^","!")
. S LRY=$P($G(LRSB(LRSB)),"^",5),$P(LRY,"!",2,5)=LRX,$P(LRY,"!",7)=$P(LRNNG,"^",7)
. S $P(LRSB(LRSB),"^",5)=LRY,(LRNG,LRNGS)=LRNNG
;
I LRUNR D ASKPLNR
;
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
;
S LRX=$P(LRNGS,"^",2,5),LRX=$TR(LRX,"^","!")
S LRY=$P($G(LRSB(LRSB)),"^",5),$P(LRY,"!",2,5)=LRX,$P(LRY,"!",7)=$P(LRNGS,"^",7)
S $P(LRSB(LRSB),"^",5)=LRY
;
Q
;
;
AMEND ; Process amended results and prompt user
;
;ZEXCEPT: LRAMEND,LRFLG,LRNG,LRNGS,LRSB,LRUID,X
;
N DIR,DIRUT,DTOUT,DUOUT,LRANS,LRI,LRJ,LRLL,LRROOT,LRSQ,LRX,LRY,Y
;
; 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)
;
; If corresponding corrected value has been deleted from LAH global
; - then cleanup cross-reference and quit
I '$D(^LAH(LRLL,1,LRSQ,LRSB)) D Q
. W !!,"The related amended result has been purged"
. W !,"Unable to process this result."
. K ^LAH("LA7 AMENDED RESULTS",LRUID,LRSB,LRLL,LRSQ)
. S X=LRX
;
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"
S DIR("?",2)="0 - No to not accept amended result and delete."
S DIR("?",3)="1 - Yes to process amended result."
S DIR("?")="or 2 - Keep which skips processing but leaves result for future processing."
D ^DIR
I $D(DIRUT) Q
S LRANS=Y
;
; Process this amended result, set LRX to amended value
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
;
; Cleanup cross-reference unless user indicates they want to keep.
I LRANS<2 D
. K ^LAH(LRLL,1,LRSQ,LRSB)
. K ^LAH("LA7 AMENDED RESULTS",LRUID,LRSB,LRLL,LRSQ)
;
; If no other results then cleanup entry in LAH.
I +$O(^LAH(LRLL,1,LRSQ,1))<1 D ZAPALL^LRVR3(LRLL,LRSQ)
;
; Restore X to either original value of X or new amended value
S X=LRX
Q
;
;
ASKPLNR ; Ask user for performing lab normal ranges and units when entering
; manually and not using values from file #60.
;
;ZEXCEPT: LRNG,LRNGS,LRRFLAG,LRSB,LRSPEC,LRTEST
;
N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRI,LRJ,LRX,LRY,Y,X,Y
;
S LRX=$TR(LRNGS,"^","!")
;
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)
S LRNGS=LRNG
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVER5 13881 printed Sep 15, 2024@21:46:43 Page 2
LRVER5 ;DALOI/STAFF - LAB ROUTINE DATA VERIFICATION ;05/12/16 09:47
+1 ;;5.2;LAB SERVICE;**42,153,283,286,350,458,488**;Sep 27, 1994;Build 1
+2 ;
+3 ; ZEXCEPT is used to identify variables which are external to a specific TAG
+4 ; used in conjunction with Eclipse M-editor.
+5 ;
+6 ;
+7 ;ZEXCEPT: LRD,LRDL,LRDUZ,LRDV,LRDVF,LREDIT,LRFP,LRNDISP,LRNG,LRNG2,LRNG3,LRNG4,LRNG5,LRNGS,LRNOVER,LRNX,LRORD,LRSA,LRSB,LRSPEC,LRTEST,LRTS,LRUID,LRVRM,SX,X
+8 ;
+9 IF $GET(LRNDISP)
Begin DoDot:1
+10 SET LRNX=0
+11 NEW LRX
FOR
SET LRNX=$ORDER(LRORD(LRNX))
if LRNX<1
QUIT
SET LRX(LRORD(LRNX))=""
+12 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
+13 ;
+14 ; Check for amended results that have arrived via an HL7 interface.
+15 ; Only allow amended results to be verified during this session.
+16 IF $DATA(^LAH("LA7 AMENDED RESULTS",LRUID))
Begin DoDot:1
+17 SET LRNX=0
+18 FOR
SET LRNX=$ORDER(LRORD(LRNX))
if 'LRNX
QUIT
IF '$DATA(^LAH("LA7 AMENDED RESULTS",LRUID,LRORD(LRNX)))
KILL LRORD(LRNX)
+19 SET LRNX=0
+20 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
+21 ;
+22 SET LRNX=0
SET LRVRM=12
+23 ;
V40 SET LRNX=$ORDER(LRORD(LRNX))
if LRNX<1
GOTO V44
DO LRSUBS
+1 ;
+2 ; Check if changing performing lab
+3 ; and if not then restore LRSB(LRSB) from LRSA if previous verified to avoid triggering change prompt.
+4 ;I $P($G(LRSB(LRSB)),"^",9),'$$PLOK^LRVERA($P(LRSB(LRSB),"^",9),$G(LRDUZ(2)),DUZ(2),LRTS) G V40
+5 IF $PIECE($GET(LRSB(LRSB)),"^",9)
IF '$$PLOK^LRVERA($PIECE(LRSB(LRSB),"^",9),$GET(LRDUZ(2)),DUZ(2),LRTS)
Begin DoDot:1
+6 IF $DATA(LRSA(LRSB))
SET LRSB(LRSB)=LRSA(LRSB)
End DoDot:1
QUIT
+7 ;
+8 DO V25
+9 ;
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 IF $DATA(^LAH("LA7 AMENDED RESULTS",LRUID,LRSB))
Begin DoDot:1
+4 WRITE !,LRTEST," "
if X'=""
WRITE @LRFP
+5 DO AMEND
if $GET(LRAMEND(LRSB))
QUIT
+6 IF SX=X
WRITE !,LRTEST," "
if X'=""
WRITE @LRFP
End DoDot:1
if SX'=X!($GET(LRAMEND(LRSB)))
GOTO V45
+7 ;
+8 ; If entering results from a reference lab and not using normal/units
+9 ; from file #60 then ask user for these values otherwise display
+10 ; current file #60 values.
+11 IF $GET(LRDUZ(2))
IF LRDUZ(2)'=DUZ(2)
Begin DoDot:1
+12 IF $GET(^LAB(60,+LRTS,1,+$GET(LRSPEC),.1))
Begin DoDot:2
+13 DO V25
+14 WRITE !!,"Current Ref Range: ",LRNG2,"-",LRNG3," Units: ",$PIECE(LRNG,"^",7)
+15 IF LRNG4=""
IF LRNG5=""
QUIT
+16 WRITE !," Critical Low: ",LRNG4," Critical High: ",LRNG5
End DoDot:2
QUIT
+17 NEW LRX,LRY
+18 DO ASKPLNR
DO NORM2
+19 SET LRX=$PIECE(LRNGS,"^",2,5)
SET LRX=$TRANSLATE(LRX,"^","!")
+20 SET LRY=$PIECE($GET(LRSB(LRSB)),"^",5)
SET $PIECE(LRY,"!",2,5)=LRX
+21 SET $PIECE(LRSB(LRSB),"^",5)=LRY
End DoDot:1
+22 ;
Q42A ;
+1 WRITE !,LRTEST," "
if X'=""
WRITE @LRFP
+2 READ "//",X:DTIME
+3 IF X'?.ANP
WRITE $CHAR(7)," No Control Characters allowed."
SET X=SX
GOTO Q42A
+4 if $LENGTH($GET(SX))&(X="")
SET X=SX
SET LRDVF=1
+5 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 ;
+1 ;ZEXCEPT: DIC,LRNUF,LRNX,LRORD,LRPLOC,LRSA,LRSB,LRSS,LRSSQ,LRTS,SX,X,Y
+2 ;
+3 SET X=$PIECE(X,U,2)
SET DIC="^LAB(60,"
SET DIC(0)="EOQZ"
DO ^DIC
if Y<1
GOTO Q42
+4 SET LRPLOC=$PIECE(Y(0),U,5)
SET LRSSQ=$PIECE(LRPLOC,";",1)
SET LRSB=$PIECE(LRPLOC,";",2)
SET LRTS=+Y
+5 IF LRSSQ=""
WRITE !,"Not in this group"
GOTO LROUT
+6 IF LRSS'=LRSSQ!'$DATA(^TMP("LR",$JOB,"TMP",LRSB))
WRITE !,"Not in this group"
GOTO LROUT
+7 SET LRNX=0
+8 FOR
SET LRNX=$ORDER(LRORD(LRNX))
if LRNX<1
QUIT
if LRSB=LRORD(LRNX)
QUIT
+9 IF LRNX
IF LRSB=LRORD(LRNX)
DO LRSUBS
DO V25
GOTO V42
+10 ;
V44 KILL SX
+1 DO COM^LRVER4
+2 SET LRNUF=1
if LRVF
SET LRSA=1
+3 QUIT
+4 ;
V45 ;
+1 ;
+2 ;ZEXCEPT: LRDFN,LRIDT,LRM,LRSA,LRSB,LRSKIP,LRSS,LRTS,LRVF,LRXD,LRXDP,SX,X
+3 ;
+4 KILL LRSKIP
+5 IF X="@"
Begin DoDot:1
+6 if '$GET(LRVF)
KILL ^LR(LRDFN,LRSS,LRIDT,LRSB)
+7 SET X=$SELECT($GET(LRVF)&($DATA(LRSB(LRSB)))&('$DATA(LRM(LRSB))):"comment",$DATA(LRM(LRSB)):"pending",$DATA(LRSA(LRSB)):"canc",1:"")
+8 SET $PIECE(LRSB(LRSB),"^")=X
SET $PIECE(LRSB(LRSB),"^",2)=""
End DoDot:1
GOTO V46
+9 ;
+10 ; If user has LRDATA security and wants to edit units and reference ranges.
+11 IF X="~"
Begin DoDot:1
+12 NEW LRKEY
+13 DO OWNSKEY^XUSRB(.LRKEY,"LRDATA")
+14 IF LRKEY(0)=1
DO EDITUNR
+15 SET X=SX
End DoDot:1
GOTO Q42A
+16 ;
+17 SET LRXD=U_$PIECE(^LAB(60,LRTS,0),U,12)
SET LRXDP=LRXD_"0)"
SET LRXDP=@LRXDP
+18 if '(X="*"!($EXTRACT(X)="?")!(X="C")!(X="#")!(X="canc")!(X="pending"))
XECUTE $PIECE(LRXDP,U,5,99)
+19 IF '$DATA(X)#2
DO HELP
GOTO V42
+20 IF $DATA(X)#2
IF X["?"
DO HELP
if '($PIECE(LRXDP,U,2)["S")
GOTO V42
+21 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
+22 IF $DATA(X)#2
IF X="C"
IF $PIECE(LRXDP,U,2)'["S"
DO COMP
GOTO V42
+23 ;
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
+8 IF LRDEL'=""
SET LRQ=1
DO XDELTACK^LRVERA
KILL LRQ
+9 IF '$GET(LRAMEND(LRSB))
DO RANGE^LRVER4
+10 ;
+11 if $PIECE(X,U)=""
SET $PIECE(LRSB(LRSB),U)=""
+12 IF $PIECE(X,U)'=""
Begin DoDot:1
+13 SET $PIECE(LRSB(LRSB),U)=X
SET $PIECE(LRSB(LRSB),U,2)=LRFLG
+14 SET LRX=$$TMPSB^LRVER1(LRSB)
SET LRY=$PIECE(LRSB(LRSB),U,3)
+15 FOR I=1:1:$LENGTH(LRX,"!")
IF $PIECE(LRY,"!",I)=""
SET $PIECE(LRY,"!",I)=$PIECE(LRX,"!",I)
+16 SET $PIECE(LRSB(LRSB),U,3)=LRY
+17 IF $PIECE($PIECE(LRSB(LRSB),U,3),"!")=""
DO RONLT^LRVER3
+18 Begin DoDot:2
+19 IF '$DATA(LRSA(LRSB))#2
Begin DoDot:3
+20 SET $PIECE(LRSB(LRSB),U,4)=$SELECT($GET(LRDUZ):LRDUZ,1:$GET(DUZ))
+21 SET $PIECE(LRSB(LRSB),U,9)=$SELECT($GET(LRDUZ(2)):LRDUZ(2),1:$GET(DUZ(2)))
End DoDot:3
QUIT
+22 if '$PIECE(LRSB(LRSB),U,4)
SET $PIECE(LRSB(LRSB),U,4)=$SELECT($GET(LRDUZ):LRDUZ,1:$GET(DUZ))
End DoDot:2
+23 SET $PIECE(LRSB(LRSB),U,5)=$TRANSLATE(LRNGS,U,"!")
+24 SET $PIECE(LRSB(LRSB),U,9)=$SELECT($GET(LRDUZ(2)):LRDUZ(2),1:$GET(DUZ(2)))
End DoDot:1
+25 if $DATA(LRNUF)
GOTO V44
KILL LRNUF
if '$DATA(LRSKIP)
GOTO V40
SET X=LRSKIP
if X["^"
GOTO Q43
GOTO V40
+26 ;
+27 ;
RANGE ;
+1 ;
+2 ;ZEXCEPT: LRDUZ,LRSB,X
+3 ;
+4 SET $PIECE(LRSB(LRSB),"^")=X
+5 ; If previous results from another laboratory then use normals and units
+6 ; associated with those results.
+7 Begin DoDot:1
+8 IF $GET(LRDUZ(2))
IF DUZ(2)'=LRDUZ(2)
DO PLNR^LRVR4
QUIT
+9 IF $PIECE(LRSB(LRSB),"^",9)
IF DUZ(2)'=$PIECE(LRSB(LRSB),"^",9)
DO PLNR^LRVR4
End DoDot:1
+10 DO RANGE^LRVER4
+11 QUIT
+12 ;
+13 ;
LRSUBS ; From LRVR5
+1 ;
+2 ;ZEXCEPT: LRNX,LRORD,LRSB,LRTS
+3 ;
+4 SET LRSB=LRORD(LRNX)
SET LRTS=$SELECT($DATA(^TMP("LR",$JOB,"TMP",LRSB))#2:^(LRSB),1:0)
+5 QUIT
+6 ;
+7 ;
LRSET ; from above and LRVR5
+1 ; Also called from Input Transform of file #60.01 field #9
+2 ;
+3 ;ZEXCEPT: DA,X
+4 ;
+5 NEW DIERR,I,LRERR,LRESULT
+6 ;
+7 ; If called from EXECUTABLE HELP of file #60, field #9 then set LRSB from DD info.
+8 IF $GET(LRSB)<1
NEW LRSB
SET LRSB=+$GET(^LAB(60,+$GET(DA(1)),.2))
+9 ;
+10 DO CHK^DIE(63.04,LRSB,"EH",X,.LRESULT,"LRERR")
+11 ;
IF LRESULT'="^"
Begin DoDot:1
+12 DO EN^DDIOL(" "_LRESULT(0),"","$C(32)")
+13 SET X=LRESULT
End DoDot:1
QUIT
+14 ;
+15 IF LRESULT="^"
Begin DoDot:1
+16 DO MSG^DIALOG("WHB","","","","LRERR")
+17 KILL X
End DoDot:1
+18 ;
+19 QUIT
+20 ;
+21 ;
COMP ; from LRVR5
+1 ;
+2 ;ZEXCEPT: C,I,X
+3 ;
+4 SET X="^%ET"
SET @^%ZOSF("TRAP")
+5 READ !,"Enter your computation: ",C:DTIME
+6 if "^"[C
QUIT
if C="?"!(C["""")
GOTO CH
SET C=$PIECE(C," ",1)
+7 SET X="TRAP^LRVER5"
SET @^%ZOSF("TRAP")
DO ^DIM
SET X="W "_C
+8 IF '$DATA(X)#2
WRITE !,"Something's wrong with the syntax."
GOTO CH
+9 FOR I=1:1:$LENGTH(C)
IF $EXTRACT(C,I)?1A
SET I=.9
QUIT
+10 if I=.9
GOTO CH
if C["/0"
GOTO CH
if C["\0"
GOTO CH
WRITE !," equals ",@C
GOTO COMP
+11 ;
TRAP ; Error trap for COMP subroutine above
+1 WRITE !!,"Error in your mathematical formula ",!
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, LRSTUF2
+1 ;
+2 ;ZEXCEPT: AGE,LRDEL,LRDUZ,LRDV,LRFP,LRNG,LRNGS,LRSA,LRSB,LRSPEC,LRTS,LRVF,N,SEX,X2
+3 ;
+4 NEW LRTX,LRX
+5 SET (LRDV,LRNG,LRDEL,LRNGS)=""
+6 IF '$DATA(^LAB(60,+LRTS,0))#2
QUIT
+7 SET LRX=+$PIECE($PIECE(^LAB(60,+LRTS,0),U,5),";",2)
+8 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)
+9 SET LRFP=$PIECE(^LAB(60,LRTX,.1),U,3)
+10 IF LRFP=""
SET LRFP="$J(X,8)"
+11 ;
+12 ; Normal ranges, units, delta checks and default value
+13 IF $DATA(^LAB(60,LRTX,1,+$GET(LRSPEC),0))
Begin DoDot:1
+14 SET LRNG=^LAB(60,LRTX,1,+$GET(LRSPEC),0)
+15 SET LRDEL=$GET(^LAB(62.1,+$PIECE(LRNG,U,8),1))
+16 SET LRDEL(1)=$GET(^LAB(62.1,+$PIECE(LRNG,U,8),2),"Q")
+17 SET X2=$PIECE(LRNG,U,9)
+18 SET LRDV=$SELECT('$DATA(LRSB(LRX)):$PIECE(LRNG,U,10),1:"")
End DoDot:1
+19 ;
+20 ; When entering results from a reference lab check if flag to use normals/units from file 60.
+21 IF $GET(LRDUZ(2))
IF LRDUZ(2)'=DUZ(2)
IF '$GET(^LAB(60,LRTX,1,+$GET(LRSPEC),.1))
DO PLNR^LRVR4
+22 ;
NORM ;
+1 ;
+2 ; Use previously stored units/normals if editing previous verified results.
+3 IF $GET(LRSB)
Begin DoDot:1
+4 IF $DATA(LRSA(LRSB))
Begin DoDot:2
+5 IF $PIECE(LRSA(LRSB),"^")?1(1"pending",1"comment",1"canc")
QUIT
+6 SET LRNG=$PIECE(LRSA(LRSB),"^",5)
SET LRNG=$TRANSLATE(LRNG,"!","^")
End DoDot:2
End DoDot:1
+7 ;
+8 DO NORM2
+9 ;
+10 QUIT
+11 ;
NORM2 ;
+1 ;
+2 ;ZEXCEPT: AGE,LRNG,LRNGS,LRX,SEX
+3 ;
+4 IF $GET(SEX)=""
SET SEX="M"
+5 IF $GET(AGE)=""
SET AGE=99
+6 ;
+7 SET LRNGS=LRNG
+8 FOR LRX=2:1:5
Begin DoDot:1
+9 NEW LRY
+10 SET LRY=$PIECE(LRNG,"^",LRX)
+11 ; enclose in quotes if text or structured numeric
+12 IF LRY'=""
IF $EXTRACT(LRY)?.(1A,1"<",1">")
SET LRY=$CHAR(34)_LRY_$CHAR(34)
+13 IF LRY'=""
IF $EXTRACT(LRY)'=$CHAR(34)
IF LRY'?.N.1".".N
SET @("LRY"_"="_LRY)
+14 SET $PIECE(LRNG,"^",LRX)=LRY
SET $PIECE(LRNGS,"^",LRX)=LRY
SET @("LRNG"_LRX)=LRY
End DoDot:1
+15 QUIT
+16 ;
+17 ;
LROUT ;
+1 ;
+2 ;ZEXCEPT: LROUT,SX
+3 ;
+4 KILL SX
+5 SET LROUT=1
+6 QUIT
+7 ;
+8 ;
HELP ; Display help prompt from test result entry.
+1 ;
+2 ;ZEXCEPT: LRXD,LRXDH
+3 ;
+4 NEW LRKEY
+5 WRITE !," ??",$CHAR(7)
SET LRXDH=LRXD_"3)"
+6 if $DATA(@LRXDH)
WRITE " ",@LRXDH
+7 WRITE !,"Enter * to report ""canc"" for canceled."
+8 WRITE !,"Enter # to report ""comment""."
+9 if '($PIECE(LRXDP,U,2)["S")
WRITE !,"Enter C to enter calculate mode."
+10 DO OWNSKEY^XUSRB(.LRKEY,"LRDATA")
+11 IF LRKEY(0)=1
WRITE !,"Enter ~ to edit units/reference ranges."
+12 QUIT
+13 ;
+14 ;
EDITUNR ; Allow user to edit units and normal reference ranges.
+1 ;
+2 ;ZEXCEPT: LRNG,LRNGS,LRSB,LRSPEC,LRTS
+3 ;
+4 NEW LRX,LRY,LRUNR
+5 SET LRUNR=0
+6 IF $DATA(^LAB(60,+LRTS,1,+$GET(LRSPEC),0))
Begin DoDot:1
+7 NEW DIR,DIRUT,DTOUT,DUOUT,LRNNG,LRNNG2,LRNNG3,LRNNG4,LRNNG5,X,Y
+8 SET LRNNG=^LAB(60,+LRTS,1,+$GET(LRSPEC),0)
+9 FOR LRX=2:1:5
Begin DoDot:2
+10 SET LRY=$PIECE(LRNNG,"^",LRX)
+11 ; enclose in quotes if text or structured numeric
+12 IF LRY'=""
IF $EXTRACT(LRY)?.(1A,1"<",1">")
SET LRY=$CHAR(34)_LRY_$CHAR(34)
+13 IF LRY'=""
IF $EXTRACT(LRY)'=$CHAR(34)
IF LRY'?.N.1".".N
SET @("LRY"_"="_LRY)
+14 SET $PIECE(LRNNG,"^",LRX)=LRY
SET @("LRNNG"_LRX)=LRY
End DoDot:2
+15 WRITE !
+16 SET DIR("A",1)="Current Laboratory Test File Values"
+17 SET DIR("A",2)="Current Ref Range: "_LRNNG2_"-"_LRNNG3_" Units: "_$PIECE(LRNNG,"^",7)
+18 IF LRNNG4=""
IF LRNNG5=""
+19 IF '$TEST
SET DIR("A",3)=" Critical Low: "_LRNNG4_" Critical High: "_LRNNG5
+20 SET DIR(0)="YO"
SET DIR("A")="Use these values"
SET DIR("B")="NO"
+21 DO ^DIR
+22 IF Y'=1
SET LRUNR=1
QUIT
+23 SET LRX=$PIECE(LRNNG,"^",2,5)
SET LRX=$TRANSLATE(LRX,"^","!")
+24 SET LRY=$PIECE($GET(LRSB(LRSB)),"^",5)
SET $PIECE(LRY,"!",2,5)=LRX
SET $PIECE(LRY,"!",7)=$PIECE(LRNNG,"^",7)
+25 SET $PIECE(LRSB(LRSB),"^",5)=LRY
SET (LRNG,LRNGS)=LRNNG
End DoDot:1
+26 ;
+27 IF LRUNR
DO ASKPLNR
+28 ;
+29 FOR LRX=2:1:5
Begin DoDot:1
+30 NEW LRY
+31 SET LRY=$PIECE(LRNG,"^",LRX)
+32 ; enclose in quotes if text or structured numeric
+33 IF LRY'=""
IF $EXTRACT(LRY)?.(1A,1"<",1">")
SET LRY=$CHAR(34)_LRY_$CHAR(34)
+34 IF LRY'=""
IF $EXTRACT(LRY)'=$CHAR(34)
IF LRY'?.N.1".".N
SET @("LRY"_"="_LRY)
+35 SET $PIECE(LRNG,"^",LRX)=LRY
SET $PIECE(LRNGS,"^",LRX)=LRY
SET @("LRNG"_LRX)=LRY
End DoDot:1
+36 ;
+37 SET LRX=$PIECE(LRNGS,"^",2,5)
SET LRX=$TRANSLATE(LRX,"^","!")
+38 SET LRY=$PIECE($GET(LRSB(LRSB)),"^",5)
SET $PIECE(LRY,"!",2,5)=LRX
SET $PIECE(LRY,"!",7)=$PIECE(LRNGS,"^",7)
+39 SET $PIECE(LRSB(LRSB),"^",5)=LRY
+40 ;
+41 QUIT
+42 ;
+43 ;
AMEND ; Process amended results and prompt user
+1 ;
+2 ;ZEXCEPT: LRAMEND,LRFLG,LRNG,LRNGS,LRSB,LRUID,X
+3 ;
+4 NEW DIR,DIRUT,DTOUT,DUOUT,LRANS,LRI,LRJ,LRLL,LRROOT,LRSQ,LRX,LRY,Y
+5 ;
+6 ; flag to indicate if amended results have been extracted from LAH
+7 SET LRAMEND=0
+8 ;
+9 ; save current value of X
+10 SET LRX=X
+11 ;
+12 SET LRROOT=$QUERY(^LAH("LA7 AMENDED RESULTS",LRUID,LRSB))
+13 IF LRROOT=""
QUIT
+14 IF $QSUBSCRIPT(LRROOT,1)'="LA7 AMENDED RESULTS"!($QSUBSCRIPT(LRROOT,2)'=LRUID)!($QSUBSCRIPT(LRROOT,3)'=LRSB)
QUIT
+15 SET LRLL=$QSUBSCRIPT(LRROOT,4)
SET LRSQ=$QSUBSCRIPT(LRROOT,5)
+16 ;
+17 ; If corresponding corrected value has been deleted from LAH global
+18 ; - then cleanup cross-reference and quit
+19 IF '$DATA(^LAH(LRLL,1,LRSQ,LRSB))
Begin DoDot:1
+20 WRITE !!,"The related amended result has been purged"
+21 WRITE !,"Unable to process this result."
+22 KILL ^LAH("LA7 AMENDED RESULTS",LRUID,LRSB,LRLL,LRSQ)
+23 SET X=LRX
End DoDot:1
QUIT
+24 ;
+25 SET LRY=^LAH(LRLL,1,LRSQ,LRSB)
+26 SET DIR(0)="SOA^0:No;1:Yes;2:Keep but do not process"
SET DIR("B")="Yes"
+27 SET DIR("A",1)=" "
SET DIR("A",2)="Amended result: "_$PIECE(LRY,"^")
+28 SET DIR("A",2)=DIR("A",2)_" flag: "_$SELECT($PIECE(LRY,"^",2)'="":$PIECE(LRY,"^",2),1:"None")
+29 SET DIR("A",2)=DIR("A",2)_" units: "_$PIECE($PIECE(LRY,"^",5),"!",7)
+30 SET DIR("A")="Accept amended results: "
+31 SET DIR("?",1)="Answer with"
+32 SET DIR("?",2)="0 - No to not accept amended result and delete."
+33 SET DIR("?",3)="1 - Yes to process amended result."
+34 SET DIR("?")="or 2 - Keep which skips processing but leaves result for future processing."
+35 DO ^DIR
+36 IF $DATA(DIRUT)
QUIT
+37 SET LRANS=Y
+38 ;
+39 ; Process this amended result, set LRX to amended value
+40 IF LRANS=1
Begin DoDot:1
+41 SET LRX=$PIECE(LRY,"^")
SET LRFLG=$PIECE(LRY,"^",2)
SET LRSB(LRSB)=LRY
SET LRJ=$PIECE(LRY,"^",5)
+42 FOR LRI=1,2,3,4,5,7,11,12
SET $PIECE(LRNG,"^",LRI)=$PIECE(LRJ,"!",LRI)
+43 SET LRNGS=LRNG
SET (LRAMEND,LRAMEND(LRSB))=1
+44 ; also process any comments
DO LRSBCOM^LRVR4
End DoDot:1
+45 ;
+46 ; Cleanup cross-reference unless user indicates they want to keep.
+47 IF LRANS<2
Begin DoDot:1
+48 KILL ^LAH(LRLL,1,LRSQ,LRSB)
+49 KILL ^LAH("LA7 AMENDED RESULTS",LRUID,LRSB,LRLL,LRSQ)
End DoDot:1
+50 ;
+51 ; If no other results then cleanup entry in LAH.
+52 IF +$ORDER(^LAH(LRLL,1,LRSQ,1))<1
DO ZAPALL^LRVR3(LRLL,LRSQ)
+53 ;
+54 ; Restore X to either original value of X or new amended value
+55 SET X=LRX
+56 QUIT
+57 ;
+58 ;
ASKPLNR ; Ask user for performing lab normal ranges and units when entering
+1 ; manually and not using values from file #60.
+2 ;
+3 ;ZEXCEPT: LRNG,LRNGS,LRRFLAG,LRSB,LRSPEC,LRTEST
+4 ;
+5 NEW DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRI,LRJ,LRX,LRY,Y,X,Y
+6 ;
+7 SET LRX=$TRANSLATE(LRNGS,"^","!")
+8 ;
+9 WRITE !!,"For test ",LRTEST
+10 SET DIR(0)="60.01,6"
+11 IF $PIECE(LRX,"!",7)'=""
SET DIR("B")=$PIECE(LRX,"!",7)
+12 DO ^DIR
+13 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+14 ; Set units into component 7 of piece 5
+15 SET $PIECE(LRX,"!",7)=Y
SET $PIECE(LRSB(LRSB),"^",5)=LRX
+16 ;
+17 ; Ask normals - high/low and critical
+18 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+19 FOR LRJ=1,2,3,4
Begin DoDot:1
+20 KILL DIR
+21 SET DIR(0)="60.01,"_LRJ
SET LRI=LRJ+1
+22 IF $PIECE(LRX,"!",LRI)'=""
Begin DoDot:2
+23 SET DIR("B")=$PIECE(LRX,"!",LRI)
+24 IF $EXTRACT(DIR("B"))=$CHAR(34)
QUIT
+25 ; enclose in quotes if text
IF DIR("B")'?.N.1".".N
SET DIR("B")=$CHAR(34)_DIR("B")_$CHAR(34)
End DoDot:2
+26 DO ^DIR
+27 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+28 SET $PIECE(LRX,"!",LRI)=Y
End DoDot:1
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+29 ;
+30 ; Ask user for normality in case user does not know high/low/critical.
+31 SET LRRFLAG(LRSB)=$$RFLAG^LRVERA($PIECE($GET(LRSB(LRSB)),"^",2))
+32 ;
+33 ; Update normal variable LRNG
+34 IF $PIECE(LRX,"!")=""
SET $PIECE(LRX,"!")=LRSPEC
+35 FOR LRI=1,2,3,4,5,7
SET $PIECE(LRNG,"^",LRI)=$PIECE(LRX,"!",LRI)
+36 SET LRNGS=LRNG
+37 ;
+38 QUIT
