LRORD2 ;VA/SLC/CJS - MORE OF LAZY ACCESSION LOGGING ;8/11/97 [ 04/09/2003 8:55 AM ]
;;5.2;LR;**1010,1018,1030**;NOV 01, 1997
;;5.2;LAB SERVICE;**121,153**;Sep 27, 1994
MORE ;get more tests, from LRORD1
LRM ; F LRSSX=LRM:1 D Q15,^DIC Q:Y<1 S LRWPC=LRWPC+1,LRTSTS=+Y,LRTX(LRTSTS)="",LRURGG=$P(Y(0),U,18) D ENQ K DIC("S") D GS^LRORD3 I LRSAMP>0&(LRSPEC>0) D Q20 S:'LREND LRM=LRM+1 I LREND K LRSAME Q
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030 -- S:Y<1 %=1 corrects an issue at Q14^LRORD1
F LRSSX=LRM:1 D Q15,^DIC S:Y<1 %=1 Q:Y<1 S LRWPC=LRWPC+1,LRTSTS=+Y,LRTX(LRTSTS)="",LRURGG=$P(Y(0),U,18) D ENQ K DIC("S") D GS^LRORD3 I LRSAMP>0&(LRSPEC>0) D Q20 S:'LREND LRM=LRM+1 I LREND K LRSAME Q
; ----- END IHS/OIT/MKK - LR*5.2*1030
K LRSAME Q
ENQ Q:$D(LRLABKY) S DIC="^LAB(60,",DA=LRTSTS,DR=6 D EN^DIQ Q
Q15 ;from LRORD
S DIC("S")="I $P(^(0),U,4)'="""""_$S('$D(LRLABKY):",""NO""'[$P(^(0),U,3)",'$P(LRLABKY,U,3):",""N""'[$P(^(0),U,3)",1:"") S:LRORDR="LC"!(LRORDR="I") DIC("S")=DIC("S")_",$P(^(0),U,9)"
S:$G(LRORDRR)="R" DIC("S")=DIC("S")_",$G(^LAB(60,Y,64))"
S DIC="^LAB(60,",DIC(0)="AEMOQZ"
Q
Q20 ;
;S LREND=0,Z=0 F S Z=$O(LROT(LRSAMP,LRSPEC,Z)) Q:Z<1 I +LROT(LRSAMP,LRSPEC,Z)=LRTSTS W !!?20," ~ ",$P(^LAB(60,LRTSTS,0),U)," ",$S($D(^LAB(62,LRSAMP,0)):$P(^(0),U),1:"")," ",$S($D(^LAB(61,LRSPEC,0)):$P(^(0),U),1:"")," ~" D DUP^LRORD2 H 2
;----- BEGIN IHS MODIFICATION LR*5.2*1018
S LREND=0,Z=0
F S Z=$O(LROT(LRSAMP,LRSPEC,Z)) Q:Z<1 I +LROT(LRSAMP,LRSPEC,Z)=LRTSTS W:'$G(BLRGUI) !!?20," ~ ",$P(^LAB(60,LRTSTS,0),U)," ",$S($D(^LAB(62,LRSAMP,0)):$P(^(0),U),1:"")," ",$S($D(^LAB(61,LRSPEC,0)):$P(^(0),U),1:"")," ~" D DUP^LRORD2 H 2
;----- END IHS MODIFICATION
Q:LREND
S LROT(LRSAMP,LRSPEC,LRSSX)=LRTSTS,LREXP=$S($P($G(^LAB(60,LRTSTS,3,+$O(^LAB(60,LRTSTS,3,"B",+LRSAMP,0)),0)),U,6):$P(^(0),U,6),$P(^LAB(60,LRTSTS,0),U,19):$P(^(0),U,19),1:0)
;I '$D(LRLABKY) S DIC="WARD REMARKS: " S DR=0 F S DR=$O(^LAB(60,LRTSTS,3,+LRSAMP,1,DR)) Q:DR'>0 W !," ",DIC,^(DR,0) S DIC=""
;-----BEGIN IHS MODIFICATION LR*5.2*1018
I '$D(LRLABKY),'$G(BLRGUI) S DIC="WARD REMARKS: " S DR=0 F S DR=$O(^LAB(60,LRTSTS,3,+LRSAMP,1,DR)) Q:DR'>0 W !," ",DIC,^(DR,0) S DIC=""
;-----END IHS MODIFICATION
S:LREXP LROT(LRSAMP,LRSPEC,LRSSX,2)=LREXP S DIC("B")=LROUTINE D URG
Q
% R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
W !,"For ",$P(^TMP("LRSTIK",$J,LRSSX),U,2)
URG ;from LRMIBL, LRORD1, LRWU1
S H=+$P(^LAB(60,+LRTSTS,0),U,16),H(0)=$P(^(0),U,18) I $D(LRURGG),LRURGG'<H S X=LRURGG K LRURGG G URG1
S:'$D(LROUTINE) LROUTINE=+$P($G(^LAB(69.9,1,3)),U,2)
;K DIC S DIC("A")="Select Urgency Status: ",DIC("S")="I '$P(^(0),U,3)",DIC="^LAB(62.05,",DIC(0)="AEQ" S DIC("B")=$S(LRORDR="WC":H(0),1:LROUTINE)
;----- BEGIN IHS MODIFICATION LR*5.2*1018
I '$G(BLRGUI) K DIC S DIC("A")="Select Urgency Status: ",DIC("S")="I '$P(^(0),U,3)",DIC="^LAB(62.05,",DIC(0)="AEQ" S DIC("B")=$S(LRORDR="WC":H(0),1:LROUTINE)
I $G(BLRGUI) S X=$P(BGUPRAM,";",4),DIC="^LAB(62.05,",DIC(0)="X" S:'$D(DIC("B")) DIC("B")=$S("WC"[LRORDR:H(0),1:"")
;----- END IHS MODIFICATION
S DIC("S")="I '$P(^(0),U,3),Y'<"_H S:LRORDR="LC" DIC("S")=DIC("S")_" I $P(^(0),U,2)" D ^DIC S:Y>0 X=+Y S:Y<1 X=9
URG1 K DIC,H S LROT(LRSAMP,LRSPEC,LRSSX,1)=X Q
RCOM ;from LRORDST, LROW1
S LRCCOM="" S:'$D(LREXP) LREXP=0 S:'$D(LRTSTNM) LRTSTNM="" ;ASK REQUIRED COMENT
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 VARIOUS ADDITIONS OF VARIABLE BLRGUI
I '$G(BLRGUI),LREXP,$L(^LAB(62.07,LREXP,.1)) X ^(.1) Q:$G(LRKIL) W:$E(LRCCOM)="?"&$D(^LAB(62.07,LREXP,.2)) ^(.2) G RCOM:$E(LRCCOM)="?"
I '$G(BLRGUI),'LREXP R !,"Enter Order Comment: ",LRCCOM:DTIME
S:$G(BLRGUI) LRCCOM=BPCCOM ;NEW LINE FOR LR*5.2*1018 PATIENT CHART
RC1 I '$G(BLRGUI) G ZQ:LRCCOM="?"!(LRCCOM="??"),Z3:LRCCOM=""!(LRCCOM="^") I LRCCOM["^"!(LRCCOM[";") W !,"No up-arrows or semicolons allowed." G ZQ
Z0 I '$G(BLRGUI) G ZQ:$L(LRCCOM)>67!($L(LRCCOM)<1)!(LRCCOM'?.ANP) S B3="~",LRPCE=$S($E(LRCCOM,1)="~":$E(LRCCOM,1),1:""),LRCCOM=$S($L(LRPCE):$E(LRCCOM,2,999),1:LRCCOM) D Z1 W " (",$E(B3,1,$L(B3)-1),")" S LRCCOM=B3 K A4,B3,B6
Z3 I '$G(BLRGUI) Q:$D(LRQ)
I '$G(BLRGUI) S:LRCCOM["^" LRCCOM="" I $L(LRCCOM) S %=1 W !," OK" D YN^DICN I %'=1 S:%=-1 LRCCOM="" G RCOM:%=2 I %=0 W !,"Unless special comments are required, this comment will be associated with",!,"all tests requested for this entry." G Z3
I $D(LRTEST(+$G(LRTSTN))) D TCOM(+LRTEST(LRTSTN),LRCCOM)
RCS ;from LREXECU, LRORDST, LROW2
Q
Z1 F V=1:1 Q:$P(LRCCOM," ",V,99)="" S B6=$P(LRCCOM," ",V),Y="" D:B6]"" Z2 S A4=$L(B3)+$L(B6) S:A4'>68 B3=B3_B6_" " I A4>68 W " too long",! Q
S LRCCOM=$S('$L(LRPCE):LRCCOM,1:LRPCE_LRCCOM) K LRPCE Q
Q
Z2 S Y=0 F S Y=$O(^LAB(62.5,"B",B6,Y)) Q:Y="" I "KA"[$P(^LAB(62.5,Y,0),U,4) S B6=$P(^LAB(62.5,Y,0),"^",2) Q:'$D(^(9)) S Y=$P(X," ",I-1),Y=$E(Y,$L(Y)) S:Y>1 B6=^(9) Q
Q
ZQ S X=$S(LRCCOM="??":"??",1:"?"),(DIE,DIC)="^LAB(62.5,",DIC(0)="Q",DIC("S")="I ""KA""[$P(^(0),U,4)",D="B",DZ=X K DO D DQ^DICQ K DIC S DIC=DIE D DO^DIC1
G RCOM
GCOM ;from LRORD1, LRPHITEM, LRTSTJAN, LRWU1
S LREXP=0 D RCOM S LRGCOM=LRCCOM Q
DUP ;from LRORDD
;I '$G(BLRGUI),LRTSTS=+LROT(LRSAMP,LRSPEC,Z) W !,"Since this test, collection sample, and site/specimen has already",!,"been requested on this order, it will NOT be duplicated.",$C(7),!,"If you really need a duplicate, place a separate order." S LREND=1
I '$G(BLRGUI),LRTSTS=+LROT(LRSAMP,LRSPEC,Z) D
. W !,"Since this test, collection sample, and site/specimen has already",!
. W "been requested on this order, it will NOT be duplicated.",$C(7),!
. W "If you really need a duplicate, place a separate order."
. S LREND=1
I $G(BLRGUI),LRTSTS=+LROT(LRSAMP,LRSPEC,Z) S LREND=1 ;NEW LINE FOR LR*5.2*1018 PATIENT CHART
Q
TCOM(TEST,COM) ;Get comments by test
N X
Q:'$G(TEST) Q:'$L($GET(COM))
S X=1+$S($D(LRTCOM(TEST)):LRTCOM(TEST),1:0),LRTCOM(TEST)=X,LRTCOM(TEST,X)="~For Test: "_$P(^LAB(60,TEST,0),"^")
S X=X+1,LRTCOM(TEST)=X,LRTCOM(TEST,X)=COM
Q
LRORD2 ;VA/SLC/CJS - MORE OF LAZY ACCESSION LOGGING ;8/11/97 [ 04/09/2003 8:55 AM ]
+1 ;;5.2;LR;**1010,1018,1030**;NOV 01, 1997
+2 ;;5.2;LAB SERVICE;**121,153**;Sep 27, 1994
MORE ;get more tests, from LRORD1
LRM ; F LRSSX=LRM:1 D Q15,^DIC Q:Y<1 S LRWPC=LRWPC+1,LRTSTS=+Y,LRTX(LRTSTS)="",LRURGG=$P(Y(0),U,18) D ENQ K DIC("S") D GS^LRORD3 I LRSAMP>0&(LRSPEC>0) D Q20 S:'LREND LRM=LRM+1 I LREND K LRSAME Q
+1 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030 -- S:Y<1 %=1 corrects an issue at Q14^LRORD1
+2 FOR LRSSX=LRM:1
DO Q15
DO ^DIC
IF Y<1
SET %=1
IF Y<1
QUIT
SET LRWPC=LRWPC+1
SET LRTSTS=+Y
SET LRTX(LRTSTS)=""
SET LRURGG=$PIECE(Y(0),U,18)
DO ENQ
KILL DIC("S")
DO GS^LRORD3
IF LRSAMP>0&(LRSPEC>0)
DO Q20
IF 'LREND
SET LRM=LRM+1
IF LREND
KILL LRSAME
QUIT
+3 ; ----- END IHS/OIT/MKK - LR*5.2*1030
+4 KILL LRSAME
QUIT
ENQ IF $DATA(LRLABKY)
QUIT
SET DIC="^LAB(60,"
SET DA=LRTSTS
SET DR=6
DO EN^DIQ
QUIT
Q15 ;from LRORD
+1 SET DIC("S")="I $P(^(0),U,4)'="""""_$SELECT('$DATA(LRLABKY):",""NO""'[$P(^(0),U,3)",'$PIECE(LRLABKY,U,3):",""N""'[$P(^(0),U,3)",1:"")
IF LRORDR="LC"!(LRORDR="I")
SET DIC("S")=DIC("S")_",$P(^(0),U,9)"
+2 IF $GET(LRORDRR)="R"
SET DIC("S")=DIC("S")_",$G(^LAB(60,Y,64))"
+3 SET DIC="^LAB(60,"
SET DIC(0)="AEMOQZ"
+4 QUIT
Q20 ;
+1 ;S LREND=0,Z=0 F S Z=$O(LROT(LRSAMP,LRSPEC,Z)) Q:Z<1 I +LROT(LRSAMP,LRSPEC,Z)=LRTSTS W !!?20," ~ ",$P(^LAB(60,LRTSTS,0),U)," ",$S($D(^LAB(62,LRSAMP,0)):$P(^(0),U),1:"")," ",$S($D(^LAB(61,LRSPEC,0)):$P(^(0),U),1:"")," ~" D DUP^LRORD2 H 2
+2 ;----- BEGIN IHS MODIFICATION LR*5.2*1018
+3 SET LREND=0
SET Z=0
+4 FOR
SET Z=$ORDER(LROT(LRSAMP,LRSPEC,Z))
IF Z<1
QUIT
IF +LROT(LRSAMP,LRSPEC,Z)=LRTSTS
IF '$GET(BLRGUI)
WRITE !!?20," ~ ",$PIECE(^LAB(60,LRTSTS,0),U)," ",$SELECT($DATA(^LAB(62,LRSAMP,0)):$PIECE(^(0),U),1:"")," ",$SELECT($DATA(^LAB(61,LRSPEC,0)):$PIECE(^(0),U),1:"")," ~"
DO DUP^LRORD2
HANG 2
+5 ;----- END IHS MODIFICATION
+6 IF LREND
QUIT
+7 SET LROT(LRSAMP,LRSPEC,LRSSX)=LRTSTS
SET LREXP=$SELECT($PIECE($GET(^LAB(60,LRTSTS,3,+$ORDER(^LAB(60,LRTSTS,3,"B",+LRSAMP,0)),0)),U,6):$PIECE(^(0),U,6),$PIECE(^LAB(60,LRTSTS,0),U,19):$PIECE(^(0),U,19),1:0)
+8 ;I '$D(LRLABKY) S DIC="WARD REMARKS: " S DR=0 F S DR=$O(^LAB(60,LRTSTS,3,+LRSAMP,1,DR)) Q:DR'>0 W !," ",DIC,^(DR,0) S DIC=""
+9 ;-----BEGIN IHS MODIFICATION LR*5.2*1018
+10 IF '$DATA(LRLABKY)
IF '$GET(BLRGUI)
SET DIC="WARD REMARKS: "
SET DR=0
FOR
SET DR=$ORDER(^LAB(60,LRTSTS,3,+LRSAMP,1,DR))
IF DR'>0
QUIT
WRITE !," ",DIC,^(DR,0)
SET DIC=""
+11 ;-----END IHS MODIFICATION
+12 IF LREXP
SET LROT(LRSAMP,LRSPEC,LRSSX,2)=LREXP
SET DIC("B")=LROUTINE
DO URG
+13 QUIT
% READ %:DTIME
IF %=""!(%["N")!(%["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO %
+1 WRITE !,"For ",$PIECE(^TMP("LRSTIK",$JOB,LRSSX),U,2)
URG ;from LRMIBL, LRORD1, LRWU1
+1 SET H=+$PIECE(^LAB(60,+LRTSTS,0),U,16)
SET H(0)=$PIECE(^(0),U,18)
IF $DATA(LRURGG)
IF LRURGG'<H
SET X=LRURGG
KILL LRURGG
GOTO URG1
+2 IF '$DATA(LROUTINE)
SET LROUTINE=+$PIECE($GET(^LAB(69.9,1,3)),U,2)
+3 ;K DIC S DIC("A")="Select Urgency Status: ",DIC("S")="I '$P(^(0),U,3)",DIC="^LAB(62.05,",DIC(0)="AEQ" S DIC("B")=$S(LRORDR="WC":H(0),1:LROUTINE)
+4 ;----- BEGIN IHS MODIFICATION LR*5.2*1018
+5 IF '$GET(BLRGUI)
KILL DIC
SET DIC("A")="Select Urgency Status: "
SET DIC("S")="I '$P(^(0),U,3)"
SET DIC="^LAB(62.05,"
SET DIC(0)="AEQ"
SET DIC("B")=$SELECT(LRORDR="WC":H(0),1:LROUTINE)
+6 IF $GET(BLRGUI)
SET X=$PIECE(BGUPRAM,";",4)
SET DIC="^LAB(62.05,"
SET DIC(0)="X"
IF '$DATA(DIC("B"))
SET DIC("B")=$SELECT("WC"[LRORDR:H(0),1:"")
+7 ;----- END IHS MODIFICATION
+8 SET DIC("S")="I '$P(^(0),U,3),Y'<"_H
IF LRORDR="LC"
SET DIC("S")=DIC("S")_" I $P(^(0),U,2)"
DO ^DIC
IF Y>0
SET X=+Y
IF Y<1
SET X=9
URG1 KILL DIC,H
SET LROT(LRSAMP,LRSPEC,LRSSX,1)=X
QUIT
RCOM ;from LRORDST, LROW1
+1 ;ASK REQUIRED COMENT
SET LRCCOM=""
IF '$DATA(LREXP)
SET LREXP=0
IF '$DATA(LRTSTNM)
SET LRTSTNM=""
+2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 VARIOUS ADDITIONS OF VARIABLE BLRGUI
+3 IF '$GET(BLRGUI)
IF LREXP
IF $LENGTH(^LAB(62.07,LREXP,.1))
XECUTE ^(.1)
IF $GET(LRKIL)
QUIT
IF $EXTRACT(LRCCOM)="?"&$DATA(^LAB(62.07,LREXP,.2))
WRITE ^(.2)
IF $EXTRACT(LRCCOM)="?"
GOTO RCOM
+4 IF '$GET(BLRGUI)
IF 'LREXP
READ !,"Enter Order Comment: ",LRCCOM:DTIME
+5 ;NEW LINE FOR LR*5.2*1018 PATIENT CHART
IF $GET(BLRGUI)
SET LRCCOM=BPCCOM
RC1 IF '$GET(BLRGUI)
IF LRCCOM="?"!(LRCCOM="??")
GOTO ZQ
IF LRCCOM=""!(LRCCOM="^")
GOTO Z3
IF LRCCOM["^"!(LRCCOM[";")
WRITE !,"No up-arrows or semicolons allowed."
GOTO ZQ
Z0 IF '$GET(BLRGUI)
IF $LENGTH(LRCCOM)>67!($LENGTH(LRCCOM)<1)!(LRCCOM'?.ANP)
GOTO ZQ
SET B3="~"
SET LRPCE=$SELECT($EXTRACT(LRCCOM,1)="~":$EXTRACT(LRCCOM,1),1:"")
SET LRCCOM=$SELECT($LENGTH(LRPCE):$EXTRACT(LRCCOM,2,999),1:LRCCOM)
DO Z1
WRITE " (",$EXTRACT(B3,1,$LENGTH(B3)-1),")"
SET LRCCOM=B3
KILL A4,B3,B6
Z3 IF '$GET(BLRGUI)
IF $DATA(LRQ)
QUIT
+1 IF '$GET(BLRGUI)
IF LRCCOM["^"
SET LRCCOM=""
IF $LENGTH(LRCCOM)
SET %=1
WRITE !," OK"
DO YN^DICN
IF %'=1
IF %=-1
SET LRCCOM=""
IF %=2
GOTO RCOM
IF %=0
WRITE !,"Unless special comments are required, this comment will be associated with",!,"all tests requested for this entry."
GOTO Z3
+2 IF $DATA(LRTEST(+$GET(LRTSTN)))
DO TCOM(+LRTEST(LRTSTN),LRCCOM)
RCS ;from LREXECU, LRORDST, LROW2
+1 QUIT
Z1 FOR V=1:1
IF $PIECE(LRCCOM," ",V,99)=""
QUIT
SET B6=$PIECE(LRCCOM," ",V)
SET Y=""
IF B6]""
DO Z2
SET A4=$LENGTH(B3)+$LENGTH(B6)
IF A4'>68
SET B3=B3_B6_" "
IF A4>68
WRITE " too long",!
QUIT
+1 SET LRCCOM=$SELECT('$LENGTH(LRPCE):LRCCOM,1:LRPCE_LRCCOM)
KILL LRPCE
QUIT
+2 QUIT
Z2 SET Y=0
FOR
SET Y=$ORDER(^LAB(62.5,"B",B6,Y))
IF Y=""
QUIT
IF "KA"[$PIECE(^LAB(62.5,Y,0),U,4)
SET B6=$PIECE(^LAB(62.5,Y,0),"^",2)
IF '$DATA(^(9))
QUIT
SET Y=$PIECE(X," ",I-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET B6=^(9)
QUIT
+1 QUIT
ZQ SET X=$SELECT(LRCCOM="??":"??",1:"?")
SET (DIE,DIC)="^LAB(62.5,"
SET DIC(0)="Q"
SET DIC("S")="I ""KA""[$P(^(0),U,4)"
SET D="B"
SET DZ=X
KILL DO
DO DQ^DICQ
KILL DIC
SET DIC=DIE
DO DO^DIC1
+1 GOTO RCOM
GCOM ;from LRORD1, LRPHITEM, LRTSTJAN, LRWU1
+1 SET LREXP=0
DO RCOM
SET LRGCOM=LRCCOM
QUIT
DUP ;from LRORDD
+1 ;I '$G(BLRGUI),LRTSTS=+LROT(LRSAMP,LRSPEC,Z) W !,"Since this test, collection sample, and site/specimen has already",!,"been requested on this order, it will NOT be duplicated.",$C(7),!,"If you really need a duplicate, place a separate order." S
LREND=1
+2 IF '$GET(BLRGUI)
IF LRTSTS=+LROT(LRSAMP,LRSPEC,Z)
Begin DoDot:1
+3 WRITE !,"Since this test, collection sample, and site/specimen has already",!
+4 WRITE "been requested on this order, it will NOT be duplicated.",$CHAR(7),!
+5 WRITE "If you really need a duplicate, place a separate order."
+6 SET LREND=1
End DoDot:1
+7 ;NEW LINE FOR LR*5.2*1018 PATIENT CHART
IF $GET(BLRGUI)
IF LRTSTS=+LROT(LRSAMP,LRSPEC,Z)
SET LREND=1
+8 QUIT
TCOM(TEST,COM) ;Get comments by test
+1 NEW X
+2 IF '$GET(TEST)
QUIT
IF '$LENGTH($GET(COM))
QUIT
+3 SET X=1+$SELECT($DATA(LRTCOM(TEST)):LRTCOM(TEST),1:0)
SET LRTCOM(TEST)=X
SET LRTCOM(TEST,X)="~For Test: "_$PIECE(^LAB(60,TEST,0),"^")
+4 SET X=X+1
SET LRTCOM(TEST)=X
SET LRTCOM(TEST,X)=COM
+5 QUIT
