LRVR4 ;DALOI/CJS/DALOI/FHS - LAB ROUTINE DATA VERIFICATION ;JUL 06, 2010 3:14 PM
;;5.2;LAB SERVICE;**14,42,121,153,221,263,279,283,287,286,330,1027**;NOV 01, 1997
I $D(LRSBCOM) D
. N LRX
. S LRX=0
. F S LRX=$O(LRSBCOM(LRX)) Q:LRX="" S ^LAH(LRLL,1,LRSQ,1,LRX)=LRSBCOM(LRX)
K %,LRSBCOM
D LOOP
Q
;
;
LOOP ; EP
S LRLCT=0
; W !!,PNM," SSN: ",SSN," "
W !!,PNM," HRCN: ",HRCN," " ; IHS/OIT/MKK - LR*5.2*1027
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 ?34," Sex: " W:$L($G(SEX)) $S(SEX="M":"MALE",SEX="F":"FEMALE",1:SEX) ; IHS/OIT/MKK - LR*5.2*1027
; W ?48," Age: ",$$CALCAGE^LRRPU(DOB,LRCDT)," as of ",$$FMTE^XLFDT(LRCDT,"1D")
W ?48," Age: ",$$CALCAGE^LRRPU(+$G(VADM(3)),LRCDT)," as of ",$$FMTE^XLFDT(LRCDT,"1D") ; IHS/OIT/MKK - LR*5.2*1027
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+3
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 LRNX=0,LRVRM=1,Z=LRCDT,LRLCT=LRLCT+1
I $P(Z1,U,7)'="" W !,"VOLUME: ",$P(Z1,U,7) S LRLCT=LRLCT+1
S LRACC=$P(Z1,U,6)
W !,"ACCESSION:",?30,$P(Z2,U,6),?44," ",LRACC
W !,LRPANEL,?30,LRDAT(2),?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 $D(LRGVP) D V20 Q
I ($O(LRSB(0))<1!$D(LRPER))&'$D(LRNUF) D LRSBCOM G EDIT
K LRNUF
D V20:'$D(LRPER) Q:$O(LRSB(1))<1 G:LREDIT EDIT
V36 ;
S LRTEC=$S($D(^LRO(68,LRAA,1,LRAD,2)):$P(^(2),U),1:$S($D(LRUSI):LRUSI,1:"")),LREDIT=0
;
V3 ;
D LRSBCOM,DCOM^LRVERA
;
; If entering reference lab results only allow editing comments/workload
K DIR
S LRLCT=0
I $G(LRDUZ(2)),DUZ(2)'=LRDUZ(2) D
. S DIR(0)="SAO^C:Comments;W:Workload"
. S DIR("A")="SELECT ('C' for Comments, 'W' Workload): "
E D
. 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=""
I X="C" D COM G LOOP
;
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 LRVR4, BACK TO LRVR3
;
;
V25 ;
I LRVF K LRSB(LRSB),LRM(LRSB) Q
I '$D(LRSB(LRSB)) S LRSB(LRSB)=^LR(LRDFN,LRSS,LRIDT,LRSB) Q
Q
;
;
V20 S LRNX=$O(LRORD(LRNX)) G V35:LRNX<1 D SUBS G V20:'LRTS
I $D(^LR(LRDFN,LRSS,LRIDT,LRSB)),^(LRSB)'["pending" D V25 G:LRVF V20
I "CH"'=LRSS G V20
D V25^LRVR5
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 X="",LRFLG=""
I $D(LRSB(LRSB)),$P(LRSB(LRSB),U)'="" D
. N LRX
. K LRNOVER(LRSB)
. S (LRDL,LRX,X)=$P(LRSB(LRSB),U)
. 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," "
. S X=LRX,Y=0
. K LRQ
. I X="" Q
. I (X="canc")!(X="comment")!(X="pending") D Q
. . W LRFLG,?56," ",$P(LRNG,U,7)
. . S LREDIT=0
. I LRDEL'="" S LRQ=1,LRVRM=11 X LRDEL S LRVRM=1 K LRQ
. D RANGE
. W LRFLG,?56," ",$P(LRNG,U,7) S:X'="" LREDIT=0
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]""
K LRNUF
Q
;
;
LRCFL ;
S LREXEC=LRCFL D ^LREXEC:LRCFL[""
D:LRLCT>22 WT
Q
;
;
EDIT ;
S LROUT=1 D ^LRVR5
S LRVRM=1,LREDIT=0
G LRCFL:LROUT!$D(LRPER),LOOP
;
;
RANGE ;
; If results from another system, use flags returned with results
; and set LRNG,LRNGS with normals from message.
; Check for LRDUZ(2) set for performing lab or performing lab set (piece 9) in LRSB(LRSB) array.
I $G(LRDUZ(2)),DUZ(2)'=LRDUZ(2) S Y=X D PLNR,CKPLNR,RQ Q
I $P(LRSB(LRSB),"^",9),DUZ(2)'=$P(LRSB(LRSB),"^",9) S Y=X D PLNR,CKPLNR,RQ Q
;
D RANGE^LRVER4,RQ
Q
;
;
RQ S X=Y
NR I $D(LRSB(LRSB))#2 D
. N I,LRX,LRY
. I $P(X,U)="" S LRSB(LRSB)="" Q
. S $P(LRSB(LRSB),U)=X
. S $P(LRSB(LRSB),U,2)=LRFLG
. S $P(LRSB(LRSB),U,4)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ))
. I $P(LRSB(LRSB),U,9)="" S $P(LRSB(LRSB),U,9)=$S($G(LRDUZ(2)):LRDUZ(2),$G(DUZ(2)):DUZ(2),1:"")
. 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
. S LRX=LRNGS,LRY=$P(LRSB(LRSB),U,5)
. F I=1:1:$L(LRX,U) I $P(LRY,"!",I)="" S $P(LRY,"!",I)=$P(LRX,U,I)
. S $P(LRSB(LRSB),U,5)=LRY
Q
;
;
PLNR ; Performing lab normal ranges, use instead of current local ranges
; Retrieve from results when "NPC" node = 2 or greater
; and set LRNG and LRNGS with normals from HL7 message/interface.
N I,LRY
I +$G(^LR(LRDFN,LRSS,LRIDT,"NPC"))<2 Q
S LRY=$P($G(LRSB(LRSB)),"^",5)
S $P(LRNGS,"^")=$P(LRY,"!")
F I=2:1:5,11,12 D
. ; enclose in quotes if not numeric
. I I<6,$P(LRY,"!",I)'?.N.1".".N S $P(LRY,"!",I)=$C(34)_$P(LRY,"!",I)_$C(34)
. S $P(LRNGS,"^",I)=$P(LRY,"!",I),$P(LRNG,"^",I)=$P(LRY,"!",I),@("LRNG"_I)=$P(LRY,"!",I)
S $P(LRNG,"^",7)=$P(LRY,"!",7),$P(LRNGS,"^",7)=$P(LRY,"!",7)
Q
;
;
CKPLNR ; Check performing lab normal ranges and set abnormal flag
; based on HL7 messages/interface.
S LRFLG=$P(LRSB(LRSB),"^",2)
I '$D(LRQ),$E(LRFLG,2)="*" D DISPFLG^LRVER4
Q
;
;
SUBS D SUBS^LRVER4
Q
;
;
WT D WT^LRVER4
Q
;
;
COM ;from LRVR5
Q:$D(LRGVP)!('$D(LRLABKY))
D DCOM^LRVERA
K DR,DA,DIE
S DIE="^LR("_LRDFN_",""CH"",",DA=LRIDT,DA(1)=LRDFN,DR=.99 D ^DIE
Q
;
;
LRSBCOM ;Display/store comments from the instrument
N LRSBCOM,LRI
S LRI=0
F S LRI=$O(^LAH(LRLL,1,LRSQ,1,LRI)) Q:LRI="" D
. S LRSBCOM=^LAH(LRLL,1,LRSQ,1,LRI)
. I $P(LRSBCOM,"^",2) Q ; Already been processed
. D LRSBCOM1
. S $P(^LAH(LRLL,1,LRSQ,1,LRI),U,2)=1 ; Mark as processed
I $G(LRQUIET) Q
W !
S LRLCT=$G(LRLCT)+1 D:LRLCT>22 WT
Q
;
;
LRSBCOM1 ; Store instrument comments in file #63
; Check for duplicate comments in ^LAH and ^LR globals
N LRDUP,LRERR,LRI,LRNOECHO,LRNOEXPD,LRX,LRY
;
; Don't echo comments/don't expand comment using lab description file.
; Used by LRNUM - called from input transform of #.01 field.
S LRNOECHO=0,LRNOEXPD=1
;
; Check for duplicates - comment stripped if spaces, force to upper case unless
; flag set to store duplicates (Field #2.2 of PROFILE multiple in file #68.2)
S LRDUP=0
I '$P($G(^LRO(68.2,LRLL,10,+$G(LRPROF),0)),U,4) D
. S LRI=0,LRY=$TR(LRSBCOM," ",""),LRY=$$UP^XLFSTR(LRY)
. F S LRI=$O(^LR(LRDFN,"CH",LRIDT,1,LRI)) Q:'LRI D Q:LRDUP
. . S LRX=$P($G(^LR(LRDFN,"CH",LRIDT,1,LRI,0)),U)
. . S LRX=$TR(LRX," ",""),LRX=$$UP^XLFSTR(LRX)
. . I LRX=LRY S LRDUP=1
I LRDUP=1 Q ; Duplicate comment
D FILECOM(LRDFN,LRIDT,LRSBCOM)
I $G(LRQUIET) Q
W !,"Inst Comments: "_LRSBCOM
S LRLCT=$G(LRLCT)+1 D:LRLCT>10 WT
Q
;
;
FILECOM(LRDFN,LRIDT,LRCMT) ; File comment in field #99
; Call with LRDFN = ien of patient in file #63
; LRIDT = ien of specimen date/time
; LRCMT = comment to store
;
N LRFDA,LRERR
S LRFDA(2,63.041,"+2,"_LRIDT_","_LRDFN_",",.01)=LRCMT
D UPDATE^DIE("","LRFDA(2)","","LRERR(2)")
Q
LRVR4 ;DALOI/CJS/DALOI/FHS - LAB ROUTINE DATA VERIFICATION ;JUL 06, 2010 3:14 PM
+1 ;;5.2;LAB SERVICE;**14,42,121,153,221,263,279,283,287,286,330,1027**;NOV 01, 1997
+2 IF $DATA(LRSBCOM)
Begin DoDot:1
+3 NEW LRX
+4 SET LRX=0
+5 FOR
SET LRX=$ORDER(LRSBCOM(LRX))
IF LRX=""
QUIT
SET ^LAH(LRLL,1,LRSQ,1,LRX)=LRSBCOM(LRX)
End DoDot:1
+6 KILL %,LRSBCOM
+7 DO LOOP
+8 QUIT
+9 ;
+10 ;
LOOP ; EP
+1 SET LRLCT=0
+2 ; W !!,PNM," SSN: ",SSN," "
+3 ; IHS/OIT/MKK - LR*5.2*1027
WRITE !!,PNM," HRCN: ",HRCN," "
+4 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:"??"))
+5 WRITE !,"Pat Info: ",$PIECE($GET(^LR(LRDFN,.091)),U)
+6 ; W ?34," Sex: ",$S(SEX="M":"MALE",SEX="F":"FEMALE",1:SEX)
+7 ; IHS/OIT/MKK - LR*5.2*1027
WRITE ?34," Sex: "
IF $LENGTH($GET(SEX))
WRITE $SELECT(SEX="M":"MALE",SEX="F":"FEMALE",1:SEX)
+8 ; W ?48," Age: ",$$CALCAGE^LRRPU(DOB,LRCDT)," as of ",$$FMTE^XLFDT(LRCDT,"1D")
+9 ; IHS/OIT/MKK - LR*5.2*1027
WRITE ?48," Age: ",$$CALCAGE^LRRPU(+$GET(VADM(3)),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+3
+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 ;
+26 WRITE !
SET LRNX=0
SET LRVRM=1
SET Z=LRCDT
SET LRLCT=LRLCT+1
+27 IF $PIECE(Z1,U,7)'=""
WRITE !,"VOLUME: ",$PIECE(Z1,U,7)
SET LRLCT=LRLCT+1
+28 SET LRACC=$PIECE(Z1,U,6)
+29 WRITE !,"ACCESSION:",?30,$PIECE(Z2,U,6),?44," ",LRACC
+30 WRITE !,LRPANEL,?30,LRDAT(2),?44," ",LRDAT
+31 SET LRLCT=LRLCT+2
+32 IF $DATA(LRALERT)
IF LRALERT<($PIECE(LRPARAM,U,20)+1)
Begin DoDot:1
+33 WRITE !?15
IF $EXTRACT(IOST,1,2)="C-"
WRITE @LRVIDO
+34 WRITE "Test ordered "_$PIECE($GET(^LAB(62.05,+LRALERT,0)),U)
+35 IF $EXTRACT(IOST,1,2)="C-"
WRITE @LRVIDOF,$CHAR(7)
+36 SET LRLCT=LRLCT+1
End DoDot:1
+37 IF $DATA(LRGVP)
DO V20
QUIT
+38 IF ($ORDER(LRSB(0))<1!$DATA(LRPER))&'$DATA(LRNUF)
DO LRSBCOM
GOTO EDIT
+39 KILL LRNUF
+40 IF '$DATA(LRPER)
DO V20
IF $ORDER(LRSB(1))<1
QUIT
IF LREDIT
GOTO EDIT
V36 ;
+1 SET LRTEC=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,2)):$PIECE(^(2),U),1:$SELECT($DATA(LRUSI):LRUSI,1:""))
SET LREDIT=0
+2 ;
V3 ;
+1 DO LRSBCOM
DO DCOM^LRVERA
+2 ;
+3 ; If entering reference lab results only allow editing comments/workload
+4 KILL DIR
+5 SET LRLCT=0
+6 IF $GET(LRDUZ(2))
IF DUZ(2)'=LRDUZ(2)
Begin DoDot:1
+7 SET DIR(0)="SAO^C:Comments;W:Workload"
+8 SET DIR("A")="SELECT ('C' for Comments, 'W' Workload): "
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 SET DIR(0)="SAO^E:Edit;C:Comments;W:Workload"
+11 SET DIR("A")="SELECT ('E' to Edit, 'C' for Comments, 'W' Workload): "
End DoDot:1
+12 DO ^DIR
+13 IF $DATA(DIRUT)
SET X="^"
GOTO V37
+14 SET X=Y
+15 IF $EXTRACT(X)="E"
SET LREDIT=1
SET X=""
+16 IF X="C"
DO COM
GOTO LOOP
+17 ;
+18 IF $EXTRACT(X)="W"
Begin DoDot:1
+19 IF $PIECE(LRPARAM,U,14)
IF $PIECE($GET(^LRO(68,LRAA,0)),U,16)
DO STD^LRCAPV
DO EN^LRCAPV
SET LREND=0
QUIT
+20 WRITE !?10,"Workload is not activated. "
End DoDot:1
GOTO LOOP
+21 ;
+22 SET X=$SELECT(X="@":"",X="":LRTEC,1:X)
SET LRTEC=X
+23 IF '$DATA(^LRO(68,LRAA,1,LRAD,2))
SET ^(2)=""
SET ^(2)=X_U_$PIECE(^(2),U,2,99)
+24 IF LREDIT
GOTO EDIT
V37 ;LEAVE LRVR4, BACK TO LRVR3
QUIT
+1 ;
+2 ;
V25 ;
+1 IF LRVF
KILL LRSB(LRSB),LRM(LRSB)
QUIT
+2 IF '$DATA(LRSB(LRSB))
SET LRSB(LRSB)=^LR(LRDFN,LRSS,LRIDT,LRSB)
QUIT
+3 QUIT
+4 ;
+5 ;
V20 SET LRNX=$ORDER(LRORD(LRNX))
IF LRNX<1
GOTO V35
DO SUBS
IF 'LRTS
GOTO V20
+1 IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRSB))
IF ^(LRSB)'["pending"
DO V25
IF LRVF
GOTO V20
+2 IF "CH"'=LRSS
GOTO V20
+3 DO V25^LRVR5
+4 WRITE !,$PIECE(^LAB(60,+LRTS,0),U)
+5 SET X1=""
+6 IF $DATA(^LR(LRDFN,LRSS,LRLDT,LRSB))
Begin DoDot:1
+7 SET X1=$PIECE(^(LRSB),U)
SET (LRDL,X)=X1
+8 IF $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET"
Begin DoDot:2
+9 SET X=$$EXTERNAL^DILFD(63.04,LRSB,"",X1)
+10 IF X=""
SET X=X1
End DoDot:2
+11 IF X'=""
WRITE ?30,@LRFP
End DoDot:1
+12 SET X=""
SET LRFLG=""
+13 IF $DATA(LRSB(LRSB))
IF $PIECE(LRSB(LRSB),U)'=""
Begin DoDot:1
+14 NEW LRX
+15 KILL LRNOVER(LRSB)
+16 SET (LRDL,LRX,X)=$PIECE(LRSB(LRSB),U)
+17 IF $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET"
Begin DoDot:2
+18 SET X=$$EXTERNAL^DILFD(63.04,LRSB,"",LRX)
+19 IF X=""
SET X=LRX
End DoDot:2
+20 WRITE ?44," ",@LRFP," "
+21 SET X=LRX
SET Y=0
+22 KILL LRQ
+23 IF X=""
QUIT
+24 IF (X="canc")!(X="comment")!(X="pending")
Begin DoDot:2
+25 WRITE LRFLG,?56," ",$PIECE(LRNG,U,7)
+26 SET LREDIT=0
End DoDot:2
QUIT
+27 IF LRDEL'=""
SET LRQ=1
SET LRVRM=11
XECUTE LRDEL
SET LRVRM=1
KILL LRQ
+28 DO RANGE
+29 WRITE LRFLG,?56," ",$PIECE(LRNG,U,7)
IF X'=""
SET LREDIT=0
End DoDot:1
+30 IF '$DATA(LRNUF)
SET LRLCT=LRLCT+1
IF $X>80
SET LRLCT=LRLCT+1
IF LRLCT>22
DO WT
IF $GET(Y)'="^"
GOTO V20
+31 ;
V35 ;
+1 IF LRCFL]""
DO LRCFL
+2 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 SET LROUT=1
DO ^LRVR5
+2 SET LRVRM=1
SET LREDIT=0
+3 IF LROUT!$DATA(LRPER)
GOTO LRCFL
GOTO LOOP
+4 ;
+5 ;
RANGE ;
+1 ; If results from another system, use flags returned with results
+2 ; and set LRNG,LRNGS with normals from message.
+3 ; Check for LRDUZ(2) set for performing lab or performing lab set (piece 9) in LRSB(LRSB) array.
+4 IF $GET(LRDUZ(2))
IF DUZ(2)'=LRDUZ(2)
SET Y=X
DO PLNR
DO CKPLNR
DO RQ
QUIT
+5 IF $PIECE(LRSB(LRSB),"^",9)
IF DUZ(2)'=$PIECE(LRSB(LRSB),"^",9)
SET Y=X
DO PLNR
DO CKPLNR
DO RQ
QUIT
+6 ;
+7 DO RANGE^LRVER4
DO RQ
+8 QUIT
+9 ;
+10 ;
RQ SET X=Y
NR IF $DATA(LRSB(LRSB))#2
Begin DoDot:1
+1 NEW I,LRX,LRY
+2 IF $PIECE(X,U)=""
SET LRSB(LRSB)=""
QUIT
+3 SET $PIECE(LRSB(LRSB),U)=X
+4 SET $PIECE(LRSB(LRSB),U,2)=LRFLG
+5 SET $PIECE(LRSB(LRSB),U,4)=$SELECT($GET(LRDUZ):LRDUZ,1:$GET(DUZ))
+6 IF $PIECE(LRSB(LRSB),U,9)=""
SET $PIECE(LRSB(LRSB),U,9)=$SELECT($GET(LRDUZ(2)):LRDUZ(2),$GET(DUZ(2)):DUZ(2),1:"")
+7 SET LRX=$$TMPSB^LRVER1(LRSB)
SET LRY=$PIECE(LRSB(LRSB),U,3)
+8 FOR I=1:1:$LENGTH(LRX,"!")
IF $PIECE(LRY,"!",I)=""
SET $PIECE(LRY,"!",I)=$PIECE(LRX,"!",I)
+9 SET $PIECE(LRSB(LRSB),U,3)=LRY
+10 IF $PIECE($PIECE(LRSB(LRSB),U,3),"!")=""
DO RONLT^LRVER3
+11 SET LRX=LRNGS
SET LRY=$PIECE(LRSB(LRSB),U,5)
+12 FOR I=1:1:$LENGTH(LRX,U)
IF $PIECE(LRY,"!",I)=""
SET $PIECE(LRY,"!",I)=$PIECE(LRX,U,I)
+13 SET $PIECE(LRSB(LRSB),U,5)=LRY
End DoDot:1
+14 QUIT
+15 ;
+16 ;
PLNR ; Performing lab normal ranges, use instead of current local ranges
+1 ; Retrieve from results when "NPC" node = 2 or greater
+2 ; and set LRNG and LRNGS with normals from HL7 message/interface.
+3 NEW I,LRY
+4 IF +$GET(^LR(LRDFN,LRSS,LRIDT,"NPC"))<2
QUIT
+5 SET LRY=$PIECE($GET(LRSB(LRSB)),"^",5)
+6 SET $PIECE(LRNGS,"^")=$PIECE(LRY,"!")
+7 FOR I=2:1:5,11,12
Begin DoDot:1
+8 ; enclose in quotes if not numeric
+9 IF I<6
IF $PIECE(LRY,"!",I)'?.N.1".".N
SET $PIECE(LRY,"!",I)=$CHAR(34)_$PIECE(LRY,"!",I)_$CHAR(34)
+10 SET $PIECE(LRNGS,"^",I)=$PIECE(LRY,"!",I)
SET $PIECE(LRNG,"^",I)=$PIECE(LRY,"!",I)
SET @("LRNG"_I)=$PIECE(LRY,"!",I)
End DoDot:1
+11 SET $PIECE(LRNG,"^",7)=$PIECE(LRY,"!",7)
SET $PIECE(LRNGS,"^",7)=$PIECE(LRY,"!",7)
+12 QUIT
+13 ;
+14 ;
CKPLNR ; Check performing lab normal ranges and set abnormal flag
+1 ; based on HL7 messages/interface.
+2 SET LRFLG=$PIECE(LRSB(LRSB),"^",2)
+3 IF '$DATA(LRQ)
IF $EXTRACT(LRFLG,2)="*"
DO DISPFLG^LRVER4
+4 QUIT
+5 ;
+6 ;
SUBS DO SUBS^LRVER4
+1 QUIT
+2 ;
+3 ;
WT DO WT^LRVER4
+1 QUIT
+2 ;
+3 ;
COM ;from LRVR5
+1 IF $DATA(LRGVP)!('$DATA(LRLABKY))
QUIT
+2 DO DCOM^LRVERA
+3 KILL DR,DA,DIE
+4 SET DIE="^LR("_LRDFN_",""CH"","
SET DA=LRIDT
SET DA(1)=LRDFN
SET DR=.99
DO ^DIE
+5 QUIT
+6 ;
+7 ;
LRSBCOM ;Display/store comments from the instrument
+1 NEW LRSBCOM,LRI
+2 SET LRI=0
+3 FOR
SET LRI=$ORDER(^LAH(LRLL,1,LRSQ,1,LRI))
IF LRI=""
QUIT
Begin DoDot:1
+4 SET LRSBCOM=^LAH(LRLL,1,LRSQ,1,LRI)
+5 ; Already been processed
IF $PIECE(LRSBCOM,"^",2)
QUIT
+6 DO LRSBCOM1
+7 ; Mark as processed
SET $PIECE(^LAH(LRLL,1,LRSQ,1,LRI),U,2)=1
End DoDot:1
+8 IF $GET(LRQUIET)
QUIT
+9 WRITE !
+10 SET LRLCT=$GET(LRLCT)+1
IF LRLCT>22
DO WT
+11 QUIT
+12 ;
+13 ;
LRSBCOM1 ; Store instrument comments in file #63
+1 ; Check for duplicate comments in ^LAH and ^LR globals
+2 NEW LRDUP,LRERR,LRI,LRNOECHO,LRNOEXPD,LRX,LRY
+3 ;
+4 ; Don't echo comments/don't expand comment using lab description file.
+5 ; Used by LRNUM - called from input transform of #.01 field.
+6 SET LRNOECHO=0
SET LRNOEXPD=1
+7 ;
+8 ; Check for duplicates - comment stripped if spaces, force to upper case unless
+9 ; flag set to store duplicates (Field #2.2 of PROFILE multiple in file #68.2)
+10 SET LRDUP=0
+11 IF '$PIECE($GET(^LRO(68.2,LRLL,10,+$GET(LRPROF),0)),U,4)
Begin DoDot:1
+12 SET LRI=0
SET LRY=$TRANSLATE(LRSBCOM," ","")
SET LRY=$$UP^XLFSTR(LRY)
+13 FOR
SET LRI=$ORDER(^LR(LRDFN,"CH",LRIDT,1,LRI))
IF 'LRI
QUIT
Begin DoDot:2
+14 SET LRX=$PIECE($GET(^LR(LRDFN,"CH",LRIDT,1,LRI,0)),U)
+15 SET LRX=$TRANSLATE(LRX," ","")
SET LRX=$$UP^XLFSTR(LRX)
+16 IF LRX=LRY
SET LRDUP=1
End DoDot:2
IF LRDUP
QUIT
End DoDot:1
+17 ; Duplicate comment
IF LRDUP=1
QUIT
+18 DO FILECOM(LRDFN,LRIDT,LRSBCOM)
+19 IF $GET(LRQUIET)
QUIT
+20 WRITE !,"Inst Comments: "_LRSBCOM
+21 SET LRLCT=$GET(LRLCT)+1
IF LRLCT>10
DO WT
+22 QUIT
+23 ;
+24 ;
FILECOM(LRDFN,LRIDT,LRCMT) ; File comment in field #99
+1 ; Call with LRDFN = ien of patient in file #63
+2 ; LRIDT = ien of specimen date/time
+3 ; LRCMT = comment to store
+4 ;
+5 NEW LRFDA,LRERR
+6 SET LRFDA(2,63.041,"+2,"_LRIDT_","_LRDFN_",",.01)=LRCMT
+7 DO UPDATE^DIE("","LRFDA(2)","","LRERR(2)")
+8 QUIT
