- 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 Feb 18, 2025@23:48:25 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