- 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 Mar 13, 2025@21:27:11 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
