LRVER4 ;DALOI/STAFF - LAB ROUTINE DATA VERIFICATION ;07/06/10 14:08
;;5.2;LAB SERVICE;**14,42,112,121,140,171,153,188,279,283,286,350,437,488**;Sep 27, 1994;Build 1
;
N LRAMEND,LRRFLAG
;
LOOP ;
S LRLCT=0
I '$D(LRGVP) D
. S:$D(LRWRDS) LRWRD=LRWRDS
. W !!,PNM," SSN: ",SSN," " S LRLCT=LRLCT+1
. I LRDPF=2 W " LOC: ",$S(LRWRD'="":LRWRD,1:$S($L($P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,7)):$P(^(0),U,7),1:"??"))
;
W !,"Pat Info: ",$P($G(^LR(LRDFN,.091)),U)
W ?34," Sex: ",$S(SEX="M":"MALE",SEX="F":"FEMALE",1:SEX)
W ?48," Age: ",$$CALCAGE^LRRPU(DOB,LRCDT)," as of ",$$FMTE^XLFDT(LRCDT,"1D")
S LRPRAC=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,8)
I LRPRAC>0,LRPRAC=+LRPRAC D GETS^DIQ(200,LRPRAC_",",".01;.132;.137;.138","E","LRPRAC(LRPRAC)","LRERR")
W !,"Provider: "
S LRLCT=LRLCT+2
I LRPRAC'="",'$D(LRPRAC(LRPRAC,200)) W LRPRAC
I LRPRAC,$D(LRPRAC(LRPRAC,200)) D
. W LRPRAC(LRPRAC,200,LRPRAC_",",.01,"E"),?40," Voice pager: ",LRPRAC(LRPRAC,200,LRPRAC_",",.137,"E")
. W !," Phone: ",LRPRAC(LRPRAC,200,LRPRAC_",",.132,"E"),?38," Digital pager: ",LRPRAC(LRPRAC,200,LRPRAC_",",.138,"E")
. S LRLCT=LRLCT+1
;
N PRAC,PR
D PRAC^LR7OMERG(LRAA,LRAD,LRAN,.PRAC)
I $O(PRAC(0)) D
. S PR=0
. F S PR=$O(PRAC(PR)) Q:PR<1 I $D(^VA(200,PR,0)) W !?14,$P(^(0),"^") S LRLCT=LRLCT+1
W ! S LRLCT=LRLCT+1
S LRNX=0,LRVRM=2,T=""
I $P(^LR(LRDFN,LRSS,LRIDT,0),U,7)'="" D
. W !,"VOLUME: ",$P(^(0),U,7)
. S LRLCT=LRLCT+1
S LRACC=$P(Z1,U,6)
W !,"ACCESSION:",?30,$P(Z2,U,6),?44," ",LRACC_" ["_LRUID,"]"
W !,?30,LRDAT(2) W ?44," ",LRDAT
S LRLCT=LRLCT+2
I $D(LRALERT),LRALERT<($P(LRPARAM,U,20)+1) D
. W !?15 W:$E(IOST,1,2)="C-" @LRVIDO
. W "Test ordered "_$P($G(^LAB(62.05,+LRALERT,0)),U)
. W:$E(IOST,1,2)="C-" @LRVIDOF,$C(7)
. S LRLCT=LRLCT+1
;
I '$O(LRORD(0)) W !!?7,$C(7),"This is not a verifiable test/accession ",! Q
V I $D(LRGVP) D V20 Q
G EDIT:($O(^LR(LRDFN,LRSS,LRIDT,1))=""!('LRVF&$D(LRPER)))&'$D(LRNUF)
K LRNUF
D V20,ND G V37:LRVF&'$D(X)#2,EDIT:LREDIT
S LRTEC=$S($D(^LRO(68,LRAA,1,LRAD,2)):$P(^(2),U),1:$S($D(LRUSI):LRUSI,1:"")),LREDIT=0
V36 ;
Q:$D(LRGVP)
K DIR
S DIR(0)="SAO^E:Edit;C:Comments;W:Workload"
S DIR("A")="SELECT ('E' to Edit, 'C' for Comments, 'W' Workload): "
D ^DIR
I $D(DIRUT) S X="^" G V37
S X=Y
S:$E(X)="E" LREDIT=1,X=""
K LRNC
I $E(X)="C" S LRNC=1 D COM K LRNC G V36
I $E(X)="W" D G LOOP
. I $P(LRPARAM,U,14),$P($G(^LRO(68,LRAA,0)),U,16) D STD^LRCAPV,EN^LRCAPV S LREND=0 Q
. W !?10," Workload is not activated."
S X=$S(X="@":"",X="":LRTEC,1:X),LRTEC=X
S:'$D(^LRO(68,LRAA,1,LRAD,2)) ^(2)="" S ^(2)=X_U_$P(^(2),U,2,99)
G EDIT:LREDIT
V37 Q ;LEAVE LRVER4, BACK TO LRVER3
;
;
V20 ;
I $G(LRCHG) D V21,LRCFL,DCOM^LRVERA Q
S LRNX=$O(LRORD(LRNX)) G V35:LRNX<1 D SUBS
G:'$G(LRTS) V20
I '$D(LRSB(LRSB)),'$D(^LR(LRDFN,LRSS,LRIDT,LRSB)) G V20
D V25^LRVER5
;
D:$D(LRGVP) PG Q:$D(LRGVP)&($D(DTOUT)!$D(DUOUT))
;
W !,$P(^LAB(60,+LRTS,0),U)
S X1=""
I $D(^LR(LRDFN,LRSS,+LRLDT,LRSB)) D
. S X1=$P(^(LRSB),U),X=X1
. I $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET" D
. . S X=$$EXTERNAL^DILFD(63.04,LRSB,"",X1)
. . I X="" S X=X1
. W:X'="" ?30,@LRFP
S (X,LRFLG)=""
I $D(LRSB(LRSB)) D
. N LRX
. K LRNOVER(LRSB)
. S (LRDL,LRX,X)=$P(LRSB(LRSB),U)
. S LREDIT=0,LRFLG=$P(LRSB(LRSB),U,2)
. I $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET" D
. . S X=$$EXTERNAL^DILFD(63.04,LRSB,"",LRX)
. . I X="" S X=LRX
. W ?44," ",@LRFP," ",LRFLG,?56," ",$P($P(LRSB(LRSB),U,5),"!",7) ;$P(LRNG,U,7)
. S X=LRX
. I X=""!(X="canc")!(X="comment")!(X="pending") Q
. S Y=0
. I LRDEL'="" S LRQ=1 D XDELTACK^LRVERA K LRQ
. W " "
. I '$D(LRQ),$E(LRFLG,2)="*" D DISPFLG^LRVER4
;
S:$P(X,U)="" $P(LRSB(LRSB),U)=""
I $P(X,U)'="" D
. N I,LRX,LRY
. 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 $P(LRSB(LRSB),U,4)!($P(LRSB(LRSB),U)="pending") Q
. . I '$D(LRSA(LRSB))#2 S $P(LRSB(LRSB),U,4)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ)),$P(LRSB(LRSB),U,9)=$S($G(LRDUZ(2)):LRDUZ(2),$G(DUZ(2)):DUZ(2),1:"") Q
. . I $P(LRSB(LRSB),U)=$P(LRSA(LRSB),U) S:$P(LRSA(LRSB),U,4) $P(LRSB(LRSB),U,4)=$P(LRSA(LRSB),U,4) S $P(LRSA(LRSB),U,3)=$P(LRSB(LRSB),U,3) Q
. . S:'$P(LRSB(LRSB),U,4) $P(LRSB(LRSB),U,4)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ)),$P(LRSB(LRSB),U,9)=$S($G(LRDUZ(2)):LRDUZ(2),$G(DUZ(2)):DUZ(2),1:"")
. I $P(LRSB(LRSB),U,5)="" S $P(LRSB(LRSB),U,5)=$TR(LRNGS,U,"!")
I '$D(LRNUF) S LRLCT=LRLCT+1 S:$X>80 LRLCT=LRLCT+1 D:LRLCT>22 WT G:$G(Y)'="^" V20
;
V35 ;
D LRCFL:LRCFL]""
D DCOM^LRVERA K LRNUF
Q
;
;
LRCFL ;
S LREXEC=LRCFL D ^LREXEC:LRCFL[""
D:LRLCT>22 WT
Q
;
;
EDIT ;
K LROUT
D ^LRVER5 S LRVRM=2 G:$G(LRCHG) LOOP G LRCFL:$D(LROUT)!$D(LRPER)
G LOOP
;
;
RANGE ;
N LRI,LRFIND
S Y=X
I X=""!(X="canc")!(X="comment")!(X="pending") Q
W " "
F LRI=1:1:$L(X) S LRFIND=$E(X,LRI) Q:LRFIND?1(1N,1A,1".",1"-",1"<",1">")
S X=$E(X,LRI,999)
;
; User has indicated specific normality to set - used when entering
; reference lab results and all the info to calculate is not available.
I $G(LRRFLAG(LRSB)) S LRFLG=$P("L^L*^H^H*","^",LRRFLAG(LRSB))
;
E D RANGECHK
I '$D(LRQ),$E(LRFLG,2)="*" D DISPFLG^LRVER4
RQ S X=Y
Q
;
;
RANGECHK ; Check result against reference ranges and set flag
;
;
; Check for numeric abnormal results
I X?.1"-".N.1".".N D Q
. I LRNG4'="",LRNG4?.1"-".N.1".".N,X<LRNG4 S LRFLG="L*" Q
. I LRNG5'="",LRNG5?.1"-".N.1".".N,X>LRNG5 S LRFLG="H*" Q
. I LRNG2'="",LRNG2?.1"-".N.1".".N,X<LRNG2 S LRFLG="L" Q
. I LRNG3'="",LRNG3?.1"-".N.1".".N,X>LRNG3 S LRFLG="H" Q
;
; Check for <> abnormal results
; "<" results checked against low values
; ">" results checked against high values
I X?1(1"<",1">").N.1".".N D Q
. N LRX
. S LRX=$E(X,2,$L(X))
. I $E(X)="<" D Q
. . I LRNG4'="",LRNG4?.N.1".".N,LRX<LRNG4 S LRFLG="L*" Q
. . I LRNG4'="",LRNG4?.N.1".".N,LRX=LRNG4 S LRFLG="L*" Q
. . I LRNG2'="",LRNG2?.N.1".".N,LRX<LRNG2 S LRFLG="L" Q
. . I LRNG2'="",LRNG2?.N.1".".N,LRX=LRNG2 S LRFLG="L" Q
. I $E(X)=">" D Q
. . I LRNG5'="",LRNG5?.N.1".".N,LRX>LRNG5 S LRFLG="H*" Q
. . I LRNG5'="",LRNG5?.N.1".".N,LRX=LRNG5 S LRFLG="H*" Q
. . I LRNG3'="",LRNG3?.N.1".".N,LRX>LRNG3 S LRFLG="H" Q
. . I LRNG3'="",LRNG3?.N.1".".N,LRX=LRNG3 S LRFLG="H" Q
;
; Check for ranges, i.e. 0-5, 6-10.
; Compare first value to abnormal value
I X?1.N1"-"1.N D Q
. I LRNG4'="",LRNG4?.N.1".".N,+X<LRNG4 S LRFLG="L*" Q
. I LRNG5'="",LRNG5?.N.1".".N,+X>LRNG5 S LRFLG="H*" Q
. I LRNG2'="",LRNG2?.N.1".".N,+X<LRNG2 S LRFLG="L" Q
. I LRNG3'="",LRNG3?.N.1".".N,+X>LRNG3 S LRFLG="H" Q
;
Q
;
;
DISPFLG ; Display critical flags
;
I $E(IOST,1,2)="C-" W $C(7),@LRVIDO
W "CRITICAL ",$S($E(LRFLG,1)="L":"LOW",$E(LRFLG,1)="H":"HIGH",1:""),"!!"
I $E(IOST,1,2)="C-" W @LRVIDOF,$C(7),$C(7)
Q
;
;
SUBS ;
S LRSB=LRORD(LRNX),LRTS=$S($D(^TMP("LR",$J,"TMP",LRSB)):^(LRSB),1:0)
Q
;
;
ND ;
K X,DIR
Q:'LRVF
I '$P($G(LRLABKY),U) D Q
. W !,"You're not authorized to edit verified data."
. S LREDIT=0
S DIR(0)="FO"
S DIR("A")="If you need to change something, enter your initials"
S DIR("?")="To change verified results, enter your initials."
D ^DIR
S X=Y K DIR
I $$UP^XLFSTR(X)'=$$UP^XLFSTR(LRUSI) S LREDIT=0 K X QUIT
I $D(X)#2,'$G(LRCHG) W ! D S LRCHG=1
. K LRSA S LRSA=1
. F S LRSA=$O(^LR(LRDFN,"CH",LRIDT,LRSA)) Q:'LRSA S LRSA(LRSA)=^(LRSA)
Q
;
;
WT S LRLCT=0 Q:$D(LRGVP)
W !,"PRESS ANY KEY TO CONTINUE, '^' TO STOP " R Y:DTIME S:'$T Y="^"
Q
;
;
COM ;from LRVER5
Q:$D(LRGVP)
K DR
S DIE="^LR("_LRDFN_",""CH"",",DA=LRIDT,DA(1)=LRDFN,DR=.99
D ^DIE,COM1:$D(LRNC)
L +^LR(LRDFN,LRSS,LRIDT):5
I $O(^LR(LRDFN,"CH",LRIDT,1,0))="" K ^LR(LRDFN,"CH",LRIDT,1)
L -^LR(LRDFN,LRSS,LRIDT)
Q
;
;
VOL ;
W !,"VOLUME: ",$P(^LR(LRDFN,LRSS,LRIDT,0),U,7),"//" R X:DTIME
G VOL:X["?" S:X'=""&(X'[U) ^(0)=$P(^(0),U,1,6)_U_X_U_$P(^(0),U,8,10)
G COM
;
;
COM1 ;
N LRX Q:'$P(^LR(LRDFN,LRSS,LRIDT,0),U,3)
D XREF^LRVER3A
S LRX=0 F S LRX=$O(^TMP("LR",$J,"TMP",LRX)) Q:LRX<1 S ^LRO(68,"AC",LRDFN,LRIDT,LRX)=""
I $L($P(^LR(LRDFN,LRSS,LRIDT,0),U,9)),$E($P(^(0),U,9))'="-" S $P(^(0),U,9)="-"_$P(^(0),U,9)
Q
;
;
PG Q:$Y<(IOSL+5)
I $E(IOST,1,2)'="C-" W @IOF Q
D PG^LRGVP
Q
;
V21 ;
N Y,LREND
S LRSB=1,LRLCT=1
F S LRSB=+$O(LRSB(LRSB)) Q:'LRSB!($G(LREND)) D
. N LRX
. S LRTS=$O(^LAB(60,"C","CH;"_LRSB_";1",0)) Q:'LRTS
. D V25^LRVER5
. W !,$P(^LAB(60,LRTS,0),U) S X1=""
. I $D(^LR(LRDFN,LRSS,+LRLDT,LRSB)) D
. . S X1=$P(^(LRSB),U),(LRDL,X)=X1
. . I $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET" D
. . . S X=$$EXTERNAL^DILFD(63.04,LRSB,"",X1)
. . . I X="" S X=X1
. . W:X'="" ?30,@LRFP
. S (LRDL,LRX,X)=$P(LRSB(LRSB),U)
. S LREDIT=0,LRFLG=$P(LRSB(LRSB),U,2)
. I $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET" D
. . S X=$$EXTERNAL^DILFD(63.04,LRSB,"",LRX)
. . I X="" S X=LRX
. W ?44," ",@LRFP," ",LRFLG,?56," ",$P(LRNG,U,7)
. S X=LRX
. I X=""!(X="canc")!(X="comment")!(X="pending") Q
. S Y=0
. I LRDEL'="" S LRQ=1 D XDELTACK^LRVERA K LRQ
. W " "
. I '$D(LRQ),$E(LRFLG,2)="*" D DISPFLG^LRVER4
. I '$D(LRNUF) S LRLCT=LRLCT+1 S:$X>80 LRLCT=LRLCT+1 D:LRLCT>15 WT S:$E($G(Y))="^" LREND=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVER4 9468 printed Apr 09, 2024@21:09:15 Page 2
LRVER4 ;DALOI/STAFF - LAB ROUTINE DATA VERIFICATION ;07/06/10 14:08
+1 ;;5.2;LAB SERVICE;**14,42,112,121,140,171,153,188,279,283,286,350,437,488**;Sep 27, 1994;Build 1
+2 ;
+3 NEW LRAMEND,LRRFLAG
+4 ;
LOOP ;
+1 SET LRLCT=0
+2 IF '$DATA(LRGVP)
Begin DoDot:1
+3 if $DATA(LRWRDS)
SET LRWRD=LRWRDS
+4 WRITE !!,PNM," SSN: ",SSN," "
SET LRLCT=LRLCT+1
+5 IF LRDPF=2
WRITE " LOC: ",$SELECT(LRWRD'="":LRWRD,1:$SELECT($LENGTH($PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,7)):$PIECE(^(0),U,7),1:"??"))
End DoDot:1
+6 ;
+7 WRITE !,"Pat Info: ",$PIECE($GET(^LR(LRDFN,.091)),U)
+8 WRITE ?34," Sex: ",$SELECT(SEX="M":"MALE",SEX="F":"FEMALE",1:SEX)
+9 WRITE ?48," Age: ",$$CALCAGE^LRRPU(DOB,LRCDT)," as of ",$$FMTE^XLFDT(LRCDT,"1D")
+10 SET LRPRAC=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,8)
+11 IF LRPRAC>0
IF LRPRAC=+LRPRAC
DO GETS^DIQ(200,LRPRAC_",",".01;.132;.137;.138","E","LRPRAC(LRPRAC)","LRERR")
+12 WRITE !,"Provider: "
+13 SET LRLCT=LRLCT+2
+14 IF LRPRAC'=""
IF '$DATA(LRPRAC(LRPRAC,200))
WRITE LRPRAC
+15 IF LRPRAC
IF $DATA(LRPRAC(LRPRAC,200))
Begin DoDot:1
+16 WRITE LRPRAC(LRPRAC,200,LRPRAC_",",.01,"E"),?40," Voice pager: ",LRPRAC(LRPRAC,200,LRPRAC_",",.137,"E")
+17 WRITE !," Phone: ",LRPRAC(LRPRAC,200,LRPRAC_",",.132,"E"),?38," Digital pager: ",LRPRAC(LRPRAC,200,LRPRAC_",",.138,"E")
+18 SET LRLCT=LRLCT+1
End DoDot:1
+19 ;
+20 NEW PRAC,PR
+21 DO PRAC^LR7OMERG(LRAA,LRAD,LRAN,.PRAC)
+22 IF $ORDER(PRAC(0))
Begin DoDot:1
+23 SET PR=0
+24 FOR
SET PR=$ORDER(PRAC(PR))
if PR<1
QUIT
IF $DATA(^VA(200,PR,0))
WRITE !?14,$PIECE(^(0),"^")
SET LRLCT=LRLCT+1
End DoDot:1
+25 WRITE !
SET LRLCT=LRLCT+1
+26 SET LRNX=0
SET LRVRM=2
SET T=""
+27 IF $PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,7)'=""
Begin DoDot:1
+28 WRITE !,"VOLUME: ",$PIECE(^(0),U,7)
+29 SET LRLCT=LRLCT+1
End DoDot:1
+30 SET LRACC=$PIECE(Z1,U,6)
+31 WRITE !,"ACCESSION:",?30,$PIECE(Z2,U,6),?44," ",LRACC_" ["_LRUID,"]"
+32 WRITE !,?30,LRDAT(2)
WRITE ?44," ",LRDAT
+33 SET LRLCT=LRLCT+2
+34 IF $DATA(LRALERT)
IF LRALERT<($PIECE(LRPARAM,U,20)+1)
Begin DoDot:1
+35 WRITE !?15
if $EXTRACT(IOST,1,2)="C-"
WRITE @LRVIDO
+36 WRITE "Test ordered "_$PIECE($GET(^LAB(62.05,+LRALERT,0)),U)
+37 if $EXTRACT(IOST,1,2)="C-"
WRITE @LRVIDOF,$CHAR(7)
+38 SET LRLCT=LRLCT+1
End DoDot:1
+39 ;
+40 IF '$ORDER(LRORD(0))
WRITE !!?7,$CHAR(7),"This is not a verifiable test/accession ",!
QUIT
V IF $DATA(LRGVP)
DO V20
QUIT
+1 if ($ORDER(^LR(LRDFN,LRSS,LRIDT,1))=""!('LRVF&$DATA(LRPER)))&'$DATA(LRNUF)
GOTO EDIT
+2 KILL LRNUF
+3 DO V20
DO ND
if LRVF&'$DATA(X)#2
GOTO V37
if LREDIT
GOTO EDIT
+4 SET LRTEC=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,2)):$PIECE(^(2),U),1:$SELECT($DATA(LRUSI):LRUSI,1:""))
SET LREDIT=0
V36 ;
+1 if $DATA(LRGVP)
QUIT
+2 KILL DIR
+3 SET DIR(0)="SAO^E:Edit;C:Comments;W:Workload"
+4 SET DIR("A")="SELECT ('E' to Edit, 'C' for Comments, 'W' Workload): "
+5 DO ^DIR
+6 IF $DATA(DIRUT)
SET X="^"
GOTO V37
+7 SET X=Y
+8 if $EXTRACT(X)="E"
SET LREDIT=1
SET X=""
+9 KILL LRNC
+10 IF $EXTRACT(X)="C"
SET LRNC=1
DO COM
KILL LRNC
GOTO V36
+11 IF $EXTRACT(X)="W"
Begin DoDot:1
+12 IF $PIECE(LRPARAM,U,14)
IF $PIECE($GET(^LRO(68,LRAA,0)),U,16)
DO STD^LRCAPV
DO EN^LRCAPV
SET LREND=0
QUIT
+13 WRITE !?10," Workload is not activated."
End DoDot:1
GOTO LOOP
+14 SET X=$SELECT(X="@":"",X="":LRTEC,1:X)
SET LRTEC=X
+15 if '$DATA(^LRO(68,LRAA,1,LRAD,2))
SET ^(2)=""
SET ^(2)=X_U_$PIECE(^(2),U,2,99)
+16 if LREDIT
GOTO EDIT
V37 ;LEAVE LRVER4, BACK TO LRVER3
QUIT
+1 ;
+2 ;
V20 ;
+1 IF $GET(LRCHG)
DO V21
DO LRCFL
DO DCOM^LRVERA
QUIT
+2 SET LRNX=$ORDER(LRORD(LRNX))
if LRNX<1
GOTO V35
DO SUBS
+3 if '$GET(LRTS)
GOTO V20
+4 IF '$DATA(LRSB(LRSB))
IF '$DATA(^LR(LRDFN,LRSS,LRIDT,LRSB))
GOTO V20
+5 DO V25^LRVER5
+6 ;
+7 if $DATA(LRGVP)
DO PG
if $DATA(LRGVP)&($DATA(DTOUT)!$DATA(DUOUT))
QUIT
+8 ;
+9 WRITE !,$PIECE(^LAB(60,+LRTS,0),U)
+10 SET X1=""
+11 IF $DATA(^LR(LRDFN,LRSS,+LRLDT,LRSB))
Begin DoDot:1
+12 SET X1=$PIECE(^(LRSB),U)
SET X=X1
+13 IF $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET"
Begin DoDot:2
+14 SET X=$$EXTERNAL^DILFD(63.04,LRSB,"",X1)
+15 IF X=""
SET X=X1
End DoDot:2
+16 if X'=""
WRITE ?30,@LRFP
End DoDot:1
+17 SET (X,LRFLG)=""
+18 IF $DATA(LRSB(LRSB))
Begin DoDot:1
+19 NEW LRX
+20 KILL LRNOVER(LRSB)
+21 SET (LRDL,LRX,X)=$PIECE(LRSB(LRSB),U)
+22 SET LREDIT=0
SET LRFLG=$PIECE(LRSB(LRSB),U,2)
+23 IF $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET"
Begin DoDot:2
+24 SET X=$$EXTERNAL^DILFD(63.04,LRSB,"",LRX)
+25 IF X=""
SET X=LRX
End DoDot:2
+26 ;$P(LRNG,U,7)
WRITE ?44," ",@LRFP," ",LRFLG,?56," ",$PIECE($PIECE(LRSB(LRSB),U,5),"!",7)
+27 SET X=LRX
+28 IF X=""!(X="canc")!(X="comment")!(X="pending")
QUIT
+29 SET Y=0
+30 IF LRDEL'=""
SET LRQ=1
DO XDELTACK^LRVERA
KILL LRQ
+31 WRITE " "
+32 IF '$DATA(LRQ)
IF $EXTRACT(LRFLG,2)="*"
DO DISPFLG^LRVER4
End DoDot:1
+33 ;
+34 if $PIECE(X,U)=""
SET $PIECE(LRSB(LRSB),U)=""
+35 IF $PIECE(X,U)'=""
Begin DoDot:1
+36 NEW I,LRX,LRY
+37 SET $PIECE(LRSB(LRSB),U)=X
SET $PIECE(LRSB(LRSB),U,2)=LRFLG
+38 SET LRX=$$TMPSB^LRVER1(LRSB)
SET LRY=$PIECE(LRSB(LRSB),U,3)
+39 FOR I=1:1:$LENGTH(LRX,"!")
IF $PIECE(LRY,"!",I)=""
SET $PIECE(LRY,"!",I)=$PIECE(LRX,"!",I)
+40 SET $PIECE(LRSB(LRSB),U,3)=LRY
+41 IF $PIECE($PIECE(LRSB(LRSB),U,3),"!")=""
DO RONLT^LRVER3
+42 Begin DoDot:2
+43 IF $PIECE(LRSB(LRSB),U,4)!($PIECE(LRSB(LRSB),U)="pending")
QUIT
+44 IF '$DATA(LRSA(LRSB))#2
SET $PIECE(LRSB(LRSB),U,4)=$SELECT($GET(LRDUZ):LRDUZ,1:$GET(DUZ))
SET $PIECE(LRSB(LRSB),U,9)=$SELECT($GET(LRDUZ(2)):LRDUZ(2),$GET(DUZ(2)):DUZ(2),1:"")
QUIT
+45 IF $PIECE(LRSB(LRSB),U)=$PIECE(LRSA(LRSB),U)
if $PIECE(LRSA(LRSB),U,4)
SET $PIECE(LRSB(LRSB),U,4)=$PIECE(LRSA(LRSB),U,4)
SET $PIECE(LRSA(LRSB),U,3)=$PIECE(LRSB(LRSB),U,3)
QUIT
+46 if '$PIECE(LRSB(LRSB),U,4)
SET $PIECE(LRSB(LRSB),U,4)=$SELECT($GET(LRDUZ):LRDUZ,1:$GET(DUZ))
SET $PIECE(LRSB(LRSB),U,9)=$SELECT($GET(LRDUZ(2)):LRDUZ(2),$GET(DUZ(2)):DUZ(2),1:"")
End DoDot:2
+47 IF $PIECE(LRSB(LRSB),U,5)=""
SET $PIECE(LRSB(LRSB),U,5)=$TRANSLATE(LRNGS,U,"!")
End DoDot:1
+48 IF '$DATA(LRNUF)
SET LRLCT=LRLCT+1
if $X>80
SET LRLCT=LRLCT+1
if LRLCT>22
DO WT
if $GET(Y)'="^"
GOTO V20
+49 ;
V35 ;
+1 if LRCFL]""
DO LRCFL
+2 DO DCOM^LRVERA
KILL LRNUF
+3 QUIT
+4 ;
+5 ;
LRCFL ;
+1 SET LREXEC=LRCFL
if LRCFL[""
DO ^LREXEC
+2 if LRLCT>22
DO WT
+3 QUIT
+4 ;
+5 ;
EDIT ;
+1 KILL LROUT
+2 DO ^LRVER5
SET LRVRM=2
if $GET(LRCHG)
GOTO LOOP
if $DATA(LROUT)!$DATA(LRPER)
GOTO LRCFL
+3 GOTO LOOP
+4 ;
+5 ;
RANGE ;
+1 NEW LRI,LRFIND
+2 SET Y=X
+3 IF X=""!(X="canc")!(X="comment")!(X="pending")
QUIT
+4 WRITE " "
+5 FOR LRI=1:1:$LENGTH(X)
SET LRFIND=$EXTRACT(X,LRI)
if LRFIND?1(1N,1A,1".",1"-",1"<",1">")
QUIT
+6 SET X=$EXTRACT(X,LRI,999)
+7 ;
+8 ; User has indicated specific normality to set - used when entering
+9 ; reference lab results and all the info to calculate is not available.
+10 IF $GET(LRRFLAG(LRSB))
SET LRFLG=$PIECE("L^L*^H^H*","^",LRRFLAG(LRSB))
+11 ;
+12 IF '$TEST
DO RANGECHK
+13 IF '$DATA(LRQ)
IF $EXTRACT(LRFLG,2)="*"
DO DISPFLG^LRVER4
RQ SET X=Y
+1 QUIT
+2 ;
+3 ;
RANGECHK ; Check result against reference ranges and set flag
+1 ;
+2 ;
+3 ; Check for numeric abnormal results
+4 IF X?.1"-".N.1".".N
Begin DoDot:1
+5 IF LRNG4'=""
IF LRNG4?.1"-".N.1".".N
IF X<LRNG4
SET LRFLG="L*"
QUIT
+6 IF LRNG5'=""
IF LRNG5?.1"-".N.1".".N
IF X>LRNG5
SET LRFLG="H*"
QUIT
+7 IF LRNG2'=""
IF LRNG2?.1"-".N.1".".N
IF X<LRNG2
SET LRFLG="L"
QUIT
+8 IF LRNG3'=""
IF LRNG3?.1"-".N.1".".N
IF X>LRNG3
SET LRFLG="H"
QUIT
End DoDot:1
QUIT
+9 ;
+10 ; Check for <> abnormal results
+11 ; "<" results checked against low values
+12 ; ">" results checked against high values
+13 IF X?1(1"<",1">").N.1".".N
Begin DoDot:1
+14 NEW LRX
+15 SET LRX=$EXTRACT(X,2,$LENGTH(X))
+16 IF $EXTRACT(X)="<"
Begin DoDot:2
+17 IF LRNG4'=""
IF LRNG4?.N.1".".N
IF LRX<LRNG4
SET LRFLG="L*"
QUIT
+18 IF LRNG4'=""
IF LRNG4?.N.1".".N
IF LRX=LRNG4
SET LRFLG="L*"
QUIT
+19 IF LRNG2'=""
IF LRNG2?.N.1".".N
IF LRX<LRNG2
SET LRFLG="L"
QUIT
+20 IF LRNG2'=""
IF LRNG2?.N.1".".N
IF LRX=LRNG2
SET LRFLG="L"
QUIT
End DoDot:2
QUIT
+21 IF $EXTRACT(X)=">"
Begin DoDot:2
+22 IF LRNG5'=""
IF LRNG5?.N.1".".N
IF LRX>LRNG5
SET LRFLG="H*"
QUIT
+23 IF LRNG5'=""
IF LRNG5?.N.1".".N
IF LRX=LRNG5
SET LRFLG="H*"
QUIT
+24 IF LRNG3'=""
IF LRNG3?.N.1".".N
IF LRX>LRNG3
SET LRFLG="H"
QUIT
+25 IF LRNG3'=""
IF LRNG3?.N.1".".N
IF LRX=LRNG3
SET LRFLG="H"
QUIT
End DoDot:2
QUIT
End DoDot:1
QUIT
+26 ;
+27 ; Check for ranges, i.e. 0-5, 6-10.
+28 ; Compare first value to abnormal value
+29 IF X?1.N1"-"1.N
Begin DoDot:1
+30 IF LRNG4'=""
IF LRNG4?.N.1".".N
IF +X<LRNG4
SET LRFLG="L*"
QUIT
+31 IF LRNG5'=""
IF LRNG5?.N.1".".N
IF +X>LRNG5
SET LRFLG="H*"
QUIT
+32 IF LRNG2'=""
IF LRNG2?.N.1".".N
IF +X<LRNG2
SET LRFLG="L"
QUIT
+33 IF LRNG3'=""
IF LRNG3?.N.1".".N
IF +X>LRNG3
SET LRFLG="H"
QUIT
End DoDot:1
QUIT
+34 ;
+35 QUIT
+36 ;
+37 ;
DISPFLG ; Display critical flags
+1 ;
+2 IF $EXTRACT(IOST,1,2)="C-"
WRITE $CHAR(7),@LRVIDO
+3 WRITE "CRITICAL ",$SELECT($EXTRACT(LRFLG,1)="L":"LOW",$EXTRACT(LRFLG,1)="H":"HIGH",1:""),"!!"
+4 IF $EXTRACT(IOST,1,2)="C-"
WRITE @LRVIDOF,$CHAR(7),$CHAR(7)
+5 QUIT
+6 ;
+7 ;
SUBS ;
+1 SET LRSB=LRORD(LRNX)
SET LRTS=$SELECT($DATA(^TMP("LR",$JOB,"TMP",LRSB)):^(LRSB),1:0)
+2 QUIT
+3 ;
+4 ;
ND ;
+1 KILL X,DIR
+2 if 'LRVF
QUIT
+3 IF '$PIECE($GET(LRLABKY),U)
Begin DoDot:1
+4 WRITE !,"You're not authorized to edit verified data."
+5 SET LREDIT=0
End DoDot:1
QUIT
+6 SET DIR(0)="FO"
+7 SET DIR("A")="If you need to change something, enter your initials"
+8 SET DIR("?")="To change verified results, enter your initials."
+9 DO ^DIR
+10 SET X=Y
KILL DIR
+11 IF $$UP^XLFSTR(X)'=$$UP^XLFSTR(LRUSI)
SET LREDIT=0
KILL X
QUIT
+12 IF $DATA(X)#2
IF '$GET(LRCHG)
WRITE !
Begin DoDot:1
+13 KILL LRSA
SET LRSA=1
+14 FOR
SET LRSA=$ORDER(^LR(LRDFN,"CH",LRIDT,LRSA))
if 'LRSA
QUIT
SET LRSA(LRSA)=^(LRSA)
End DoDot:1
SET LRCHG=1
+15 QUIT
+16 ;
+17 ;
WT SET LRLCT=0
if $DATA(LRGVP)
QUIT
+1 WRITE !,"PRESS ANY KEY TO CONTINUE, '^' TO STOP "
READ Y:DTIME
if '$TEST
SET Y="^"
+2 QUIT
+3 ;
+4 ;
COM ;from LRVER5
+1 if $DATA(LRGVP)
QUIT
+2 KILL DR
+3 SET DIE="^LR("_LRDFN_",""CH"","
SET DA=LRIDT
SET DA(1)=LRDFN
SET DR=.99
+4 DO ^DIE
if $DATA(LRNC)
DO COM1
+5 LOCK +^LR(LRDFN,LRSS,LRIDT):5
+6 IF $ORDER(^LR(LRDFN,"CH",LRIDT,1,0))=""
KILL ^LR(LRDFN,"CH",LRIDT,1)
+7 LOCK -^LR(LRDFN,LRSS,LRIDT)
+8 QUIT
+9 ;
+10 ;
VOL ;
+1 WRITE !,"VOLUME: ",$PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,7),"//"
READ X:DTIME
+2 if X["?"
GOTO VOL
if X'=""&(X'[U)
SET ^(0)=$PIECE(^(0),U,1,6)_U_X_U_$PIECE(^(0),U,8,10)
+3 GOTO COM
+4 ;
+5 ;
COM1 ;
+1 NEW LRX
if '$PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,3)
QUIT
+2 DO XREF^LRVER3A
+3 SET LRX=0
FOR
SET LRX=$ORDER(^TMP("LR",$JOB,"TMP",LRX))
if LRX<1
QUIT
SET ^LRO(68,"AC",LRDFN,LRIDT,LRX)=""
+4 IF $LENGTH($PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,9))
IF $EXTRACT($PIECE(^(0),U,9))'="-"
SET $PIECE(^(0),U,9)="-"_$PIECE(^(0),U,9)
+5 QUIT
+6 ;
+7 ;
PG if $Y<(IOSL+5)
QUIT
+1 IF $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
QUIT
+2 DO PG^LRGVP
+3 QUIT
+4 ;
V21 ;
+1 NEW Y,LREND
+2 SET LRSB=1
SET LRLCT=1
+3 FOR
SET LRSB=+$ORDER(LRSB(LRSB))
if 'LRSB!($GET(LREND))
QUIT
Begin DoDot:1
+4 NEW LRX
+5 SET LRTS=$ORDER(^LAB(60,"C","CH;"_LRSB_";1",0))
if 'LRTS
QUIT
+6 DO V25^LRVER5
+7 WRITE !,$PIECE(^LAB(60,LRTS,0),U)
SET X1=""
+8 IF $DATA(^LR(LRDFN,LRSS,+LRLDT,LRSB))
Begin DoDot:2
+9 SET X1=$PIECE(^(LRSB),U)
SET (LRDL,X)=X1
+10 IF $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET"
Begin DoDot:3
+11 SET X=$$EXTERNAL^DILFD(63.04,LRSB,"",X1)
+12 IF X=""
SET X=X1
End DoDot:3
+13 if X'=""
WRITE ?30,@LRFP
End DoDot:2
+14 SET (LRDL,LRX,X)=$PIECE(LRSB(LRSB),U)
+15 SET LREDIT=0
SET LRFLG=$PIECE(LRSB(LRSB),U,2)
+16 IF $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET"
Begin DoDot:2
+17 SET X=$$EXTERNAL^DILFD(63.04,LRSB,"",LRX)
+18 IF X=""
SET X=LRX
End DoDot:2
+19 WRITE ?44," ",@LRFP," ",LRFLG,?56," ",$PIECE(LRNG,U,7)
+20 SET X=LRX
+21 IF X=""!(X="canc")!(X="comment")!(X="pending")
QUIT
+22 SET Y=0
+23 IF LRDEL'=""
SET LRQ=1
DO XDELTACK^LRVERA
KILL LRQ
+24 WRITE " "
+25 IF '$DATA(LRQ)
IF $EXTRACT(LRFLG,2)="*"
DO DISPFLG^LRVER4
+26 IF '$DATA(LRNUF)
SET LRLCT=LRLCT+1
if $X>80
SET LRLCT=LRLCT+1
if LRLCT>15
DO WT
if $EXTRACT($GET(Y))="^"
SET LREND=1
End DoDot:1
+27 QUIT
