LRVR5 ;DALOI/CJS/DALOI/FHS - LAB ROUTINE DATA VERIFICATION ;4/20/89 18:02
;;5.2;LAB SERVICE;**1,42,153,263,283,286,437**;Sep 27, 1994;Build 3
;
S LRNX=0,LRVRM=11
V40 ;
S LRNX=$O(LRORD(LRNX))
G V44:LRNX<1 D SUBS G V40:'LRTS,V40:'$D(LRVTS(LRSB))
;
; Only allow verifying reference lab results which exist in LAH, no
; entering results "on the fly" - use EM options (^LRVER)
I $G(LRDUZ(2)),LRDUZ(2)'=DUZ(2),'$D(^LAH(LRLL,1,LRSQ,LRSB)) K LRSB(LRSB) G V40
;
I $D(^LR(LRDFN,LRSS,LRIDT,LRSB)),^(LRSB)'["pending" D V25^LRVR4 G:LRVF V40
V42 D V25
S X=$S($D(LRSB(LRSB)):$P(LRSB(LRSB),U),1:""),LREDIT=0
I X="",LRDV'="" S $P(LRSB(LRSB),"^")=LRDV,X=LRDV
S LRTEST=$P(^LAB(60,+LRTS,0),U),LROUT=0 K LRNOVER(LRSB)
Q42 W !,LRTEST," " W:X'="" @LRFP R "//",X:DTIME I X'?.ANP W $C(7)," No Control Characters Allowed." G V42
I X=""&$D(LRSB(LRSB)) S X=$P(LRSB(LRSB),U)
Q43 S LRDL=X G V40:X="",V45:X'["^",V44:X="^",OUT: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 OUT
I LRSS'=LRSSQ!'$D(^TMP("LR",$J,"TMP",LRSB)) W !,"Not in this group" G OUT
F LRNX=0:0 S LRNX=$O(LRORD(LRNX)) Q:LRNX<1 G V42:LRSB=LRORD(LRNX)
V44 D COM^LRVR4
S LRNUF=1
Q
;
;
V45 ;
K LRSKIP
S LRDL=X
I X="@" D G V46
. S X=$S($D(LRM(LRSB)):"pending",1:"")
. S $P(LRSB(LRSB),"^")=X,$P(LRSB(LRSB),"^",2)=""
;
S X7=U_$P(^LAB(60,+LRTS,0),U,12),X6=X7_"0)"
X:'(X="*"!($E(X)="?")!(X="C")!(X="#")!(X="canc")!(X="pending")) $P(@X6,U,5,99)
I '$D(X)#2 D HELP G V42
I $D(X)#2,X["?" D HELP G:'($P(@X6,U,2)["S") V42
I $D(X)#2,$P(@X6,U,2)["S",X'="*",X'="#",X'="canc",X'="pending" D SET G:'$D(X)#2 V42
I $D(X)#2,X="C",$P(@X6,U,2)'["S" D COMP^LRVER5 G V42
;
V46 G V44:'$D(X)#2
S X1=$S($D(^LR(LRDFN,LRSS,LRLDT,LRSB)):$P(^(LRSB),U),1:""),LRFLG=""
S:X="*" X="canc" S:X="#" X="comment"
K LRQ S Y=0
I LRDEL'="" S LRQ=1 D XDELTACK^LRVERA K LRQ
D RANGE
G:$D(LRNUF) V44
K LRNUF
G V40:'$D(LRSKIP)
S X=LRSKIP
G Q43:X["^",V40
G RANGE
;
;
RANGE D RANGE^LRVER5
RQ S X=Y
NR ;
S:$P(X,U)="" LRSB(LRSB)="" Q:$D(LRQ)
I $P(X,U)'="" D
. N I,LRX,LRY
. S $P(LRSB(LRSB),U,1,2)=X_U_LRFLG
. S $P(LRSB(LRSB),U,4)=$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
. 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
;
;
SUBS ;
D LRSUBS^LRVER5
Q
;
;
SET ;
D LRSET^LRVER5
Q
;
;
HUH W !,"CHOOSE:" F I=1:1 S LRSUBS=$P(LRSET,";",I) Q:LRSUBS="" W !,$P(LRSUBS,":")," FOR ",$P(LRSUBS,":",2)
K X
Q
;
;
V25 ; From LRVR4
D V25^LRVER5
Q
;
;
OUT S LROUT=1
Q
;
;
HELP ;
W !," ??",$C(7)
S X5=X7_"3)"
W:$D(@X5) " ",@X5
W !,"Enter * to report ""canc"" for canceled."
W !,"Enter # to report ""comment""."
W:'($P(@X6,U,2)["S") !,"Enter C to enter calculate mode."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVR5 3167 printed Nov 22, 2024@17:32:46 Page 2
LRVR5 ;DALOI/CJS/DALOI/FHS - LAB ROUTINE DATA VERIFICATION ;4/20/89 18:02
+1 ;;5.2;LAB SERVICE;**1,42,153,263,283,286,437**;Sep 27, 1994;Build 3
+2 ;
+3 SET LRNX=0
SET LRVRM=11
V40 ;
+1 SET LRNX=$ORDER(LRORD(LRNX))
+2 if LRNX<1
GOTO V44
DO SUBS
if 'LRTS
GOTO V40
if '$DATA(LRVTS(LRSB))
GOTO V40
+3 ;
+4 ; Only allow verifying reference lab results which exist in LAH, no
+5 ; entering results "on the fly" - use EM options (^LRVER)
+6 IF $GET(LRDUZ(2))
IF LRDUZ(2)'=DUZ(2)
IF '$DATA(^LAH(LRLL,1,LRSQ,LRSB))
KILL LRSB(LRSB)
GOTO V40
+7 ;
+8 IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRSB))
IF ^(LRSB)'["pending"
DO V25^LRVR4
if LRVF
GOTO V40
V42 DO V25
+1 SET X=$SELECT($DATA(LRSB(LRSB)):$PIECE(LRSB(LRSB),U),1:"")
SET LREDIT=0
+2 IF X=""
IF LRDV'=""
SET $PIECE(LRSB(LRSB),"^")=LRDV
SET X=LRDV
+3 SET LRTEST=$PIECE(^LAB(60,+LRTS,0),U)
SET LROUT=0
KILL LRNOVER(LRSB)
Q42 WRITE !,LRTEST," "
if X'=""
WRITE @LRFP
READ "//",X:DTIME
IF X'?.ANP
WRITE $CHAR(7)," No Control Characters Allowed."
GOTO V42
+1 IF X=""&$DATA(LRSB(LRSB))
SET X=$PIECE(LRSB(LRSB),U)
Q43 SET LRDL=X
if X=""
GOTO V40
if X'["^"
GOTO V45
if X="^"
GOTO V44
if X="^^"
GOTO OUT
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 OUT
+3 IF LRSS'=LRSSQ!'$DATA(^TMP("LR",$JOB,"TMP",LRSB))
WRITE !,"Not in this group"
GOTO OUT
+4 FOR LRNX=0:0
SET LRNX=$ORDER(LRORD(LRNX))
if LRNX<1
QUIT
if LRSB=LRORD(LRNX)
GOTO V42
V44 DO COM^LRVR4
+1 SET LRNUF=1
+2 QUIT
+3 ;
+4 ;
V45 ;
+1 KILL LRSKIP
+2 SET LRDL=X
+3 IF X="@"
Begin DoDot:1
+4 SET X=$SELECT($DATA(LRM(LRSB)):"pending",1:"")
+5 SET $PIECE(LRSB(LRSB),"^")=X
SET $PIECE(LRSB(LRSB),"^",2)=""
End DoDot:1
GOTO V46
+6 ;
+7 SET X7=U_$PIECE(^LAB(60,+LRTS,0),U,12)
SET X6=X7_"0)"
+8 if '(X="*"!($EXTRACT(X)="?")!(X="C")!(X="#")!(X="canc")!(X="pending"))
XECUTE $PIECE(@X6,U,5,99)
+9 IF '$DATA(X)#2
DO HELP
GOTO V42
+10 IF $DATA(X)#2
IF X["?"
DO HELP
if '($PIECE(@X6,U,2)["S")
GOTO V42
+11 IF $DATA(X)#2
IF $PIECE(@X6,U,2)["S"
IF X'="*"
IF X'="#"
IF X'="canc"
IF X'="pending"
DO SET
if '$DATA(X)#2
GOTO V42
+12 IF $DATA(X)#2
IF X="C"
IF $PIECE(@X6,U,2)'["S"
DO COMP^LRVER5
GOTO V42
+13 ;
V46 if '$DATA(X)#2
GOTO V44
+1 SET X1=$SELECT($DATA(^LR(LRDFN,LRSS,LRLDT,LRSB)):$PIECE(^(LRSB),U),1:"")
SET LRFLG=""
+2 if X="*"
SET X="canc"
if X="#"
SET X="comment"
+3 KILL LRQ
SET Y=0
+4 IF LRDEL'=""
SET LRQ=1
DO XDELTACK^LRVERA
KILL LRQ
+5 DO RANGE
+6 if $DATA(LRNUF)
GOTO V44
+7 KILL LRNUF
+8 if '$DATA(LRSKIP)
GOTO V40
+9 SET X=LRSKIP
+10 if X["^"
GOTO Q43
GOTO V40
+11 GOTO RANGE
+12 ;
+13 ;
RANGE DO RANGE^LRVER5
RQ SET X=Y
NR ;
+1 if $PIECE(X,U)=""
SET LRSB(LRSB)=""
if $DATA(LRQ)
QUIT
+2 IF $PIECE(X,U)'=""
Begin DoDot:1
+3 NEW I,LRX,LRY
+4 SET $PIECE(LRSB(LRSB),U,1,2)=X_U_LRFLG
+5 SET $PIECE(LRSB(LRSB),U,4)=$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 SET LRX=LRNGS
SET LRY=$PIECE(LRSB(LRSB),U,5)
+11 FOR I=1:1:$LENGTH(LRX,U)
IF $PIECE(LRY,"!",I)=""
SET $PIECE(LRY,"!",I)=$PIECE(LRX,U,I)
+12 SET $PIECE(LRSB(LRSB),U,5)=LRY
End DoDot:1
+13 QUIT
+14 ;
+15 ;
SUBS ;
+1 DO LRSUBS^LRVER5
+2 QUIT
+3 ;
+4 ;
SET ;
+1 DO LRSET^LRVER5
+2 QUIT
+3 ;
+4 ;
HUH WRITE !,"CHOOSE:"
FOR I=1:1
SET LRSUBS=$PIECE(LRSET,";",I)
if LRSUBS=""
QUIT
WRITE !,$PIECE(LRSUBS,":")," FOR ",$PIECE(LRSUBS,":",2)
+1 KILL X
+2 QUIT
+3 ;
+4 ;
V25 ; From LRVR4
+1 DO V25^LRVER5
+2 QUIT
+3 ;
+4 ;
OUT SET LROUT=1
+1 QUIT
+2 ;
+3 ;
HELP ;
+1 WRITE !," ??",$CHAR(7)
+2 SET X5=X7_"3)"
+3 if $DATA(@X5)
WRITE " ",@X5
+4 WRITE !,"Enter * to report ""canc"" for canceled."
+5 WRITE !,"Enter # to report ""comment""."
+6 if '($PIECE(@X6,U,2)["S")
WRITE !,"Enter C to enter calculate mode."
+7 QUIT
