LRVER4 ;DALOI/CJS/DALOI/FHS - LAB ROUTINE DATA VERIFICATION ; 13-Oct-2017 14:04 ; MKK
;;5.2;LAB SERVICE;**14,42,112,121,140,171,153,188,279,283,1018,286,1027,1030,1033,1038,1039,1041**;NOV 01, 1997;Build 23
;
N LRAMEND,LRRFLAG
;
LOOP ;
;
S LRLCT=0
D UPDTCOML^BLRAAORU(+$G(LRDFN),+$G(LRIDT),+$G(LRODT),+$G(LRSN)) ; IHS/OIT/MKK - LR*5.2*1030
I '$D(LRGVP) D
. S:$D(LRWRDS) LRWRD=LRWRDS
. ; W !!,PNM," SSN: ",SSN," " S LRLCT=LRLCT+1
. W !!,PNM," HRCN: ",HRCN," " S LRLCT=LRLCT+1 ; IHS/OIT/MKK MODIFICATIONS 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: " 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+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
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 ; EP
;
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,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 X LRDEL 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:"")
. 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
;
I $L($T(QUALCHEK^BLRQUALU)),$$QUALCHEK^BLRQUALU() Q ; IHS/MSC/MKK - LR*5.2*1041 - Qualitative check
;
I X[":"&((LRNG2[":")!(LRNG3[":")!(LRNG4[":")!(LRNG5[":")) D IHSCHECK Q ; IHS/MSC/MKK - LR*5.2*1033
;
I $E(LRNG2,2)="<"!($E(LRNG3,2)=">")!($E(LRNG4,2)="<")!($E(LRNG5,2)=">") D IHSLOGIC Q ; IHS/MSC/MKK - LR*5.2*1033
I $E(LRNG2,2)=">"!($E(LRNG3,2)="<")!($E(LRNG4,2)=">")!($E(LRNG5,2)="<") D IHSLOGIC Q ; IHS/MSC/MKK - LR*5.2*1033
;
; 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
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
; Special logic for Titer results
IHSCHECK ; EP
NEW RESULT,CHEK
;
S RESULT=$P(X,":",2) Q:$L(RESULT)<1 ; If no result, skip
;
S CHEK=$P(LRNG4,":",2) I $L(CHEK),RESULT<CHEK S LRFLG="L*" Q
S CHEK=$P(LRNG5,":",2) I $L(CHEK),RESULT>CHEK S LRFLG="H*" Q
S CHEK=$P(LRNG2,":",2) I $L(CHEK),RESULT<CHEK S LRFLG="L" Q
S CHEK=$P(LRNG3,":",2) I $L(CHEK),RESULT>CHEK S LRFLG="H" Q
Q
;
; Special logic for Ref Range beginning with > or < symbol
IHSLOGIC ; EP
NEW IHSLRNG2,IHSLRNG3,IHSLRNG4,IHSLRNG5
;
S (IHSLRNG2,IHSLRNG3,IHSLRNG4,IHSLRNG5)=""
;
I $E(LRNG2,2)="<" D IHSRLOW(LRNG2,.IHSLRNG2)
I $E(LRNG2,2)=">" D IHSHIGH(LRNG2,.IHSLRNG2)
I $E(LRNG3,2)="<" D IHSRLOW(LRNG3,.IHSLRNG3)
I $E(LRNG3,2)=">" D IHSHIGH(LRNG3,.IHSLRNG3)
I $E(LRNG4,2)="<" D IHSRLOW(LRNG4,.IHSLRNG4)
I $E(LRNG4,2)=">" D IHSHIGH(LRNG4,.IHSLRNG4)
I $E(LRNG5,2)="<" D IHSRLOW(LRNG5,.IHSLRNG5)
I $E(LRNG5,2)=">" D IHSHIGH(LRNG5,.IHSLRNG5)
;
I IHSLRNG4'="",IHSLRNG4?.1"-".N.1".".N,X<IHSLRNG4 S LRFLG="L*" Q
I IHSLRNG5'="",IHSLRNG5?.1"-".N.1".".N,X>IHSLRNG5 S LRFLG="H*" Q
I IHSLRNG2'="",IHSLRNG2?.1"-".N.1".".N,X<IHSLRNG2 S LRFLG="L" Q
I IHSLRNG3'="",IHSLRNG3?.1"-".N.1".".N,X>IHSLRNG3 S LRFLG="H" Q
Q
;
IHSRLOW(LRNG,IHSRNG) ; EP - Reset low
NEW NUMDEC,SUBTRACT
S SUBTRACT=1
S NUMDEC=$L($P(LRNG,".",2))
I NUMDEC S SUBTRACT="."_$TR($J("",NUMDEC)," ","0")_"1"
S IHSRNG=$P($P(LRNG,"<",2)," ")-SUBTRACT
Q
;
IHSHIGH(LRNG,IHSRNG) ; EP - Reset High
NEW NUMDEC,ADDON
S ADDON=1
S NUMDEC=$L($P(LRNG,".",2))
I NUMDEC S ADDON="."_$TR($J("",NUMDEC)," ","0")_"1"
S IHSRNG=$P($P(LRNG,">",2)," ")+ADDON
Q
; ----- END IHS/MSC/MKK - LR*5.2*1033
;
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
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038 -- Mask User input.
D ; DO Statement used to ensure variables ANSWER, STEP, & TEXT are strictly local
. NEW ANSWER,STEP,TEXT
. K X
. W !,"If you need to change something, enter your initials: "
. S ANSWER=""
. ; F STEP=1:1:4 R TEXT#1 S:TEXT="^" ANSWER="^" Q:TEXT="^"!(TEXT="") S ANSWER=ANSWER_TEXT W $C(8),"*"
. F STEP=1:1:6 R TEXT#1 S:TEXT="^" ANSWER="^" Q:TEXT="^"!(TEXT="") S ANSWER=ANSWER_TEXT W $C(8),"*" ; IHS/MSC/MKK - LR*5.2*1039
. S LRINI=ANSWER
. S X=ANSWER
; ----- END IHS/MSC/MKK - LR*5.2*1038
;
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 ; EP
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)
;
I $G(^LR(LRDFN,"CH",LRIDT,1,1,0))["ASK AT ORDER" D AFTRAAOQ Q ; IHS/OIT/MKK - LR*5.2*1030
D GETCCDTA^BLRCCPED(LRDFN,"CH",LRIDT) ; IHS/MSC/MKK - LR*5.2*1033
;
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
;
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
AFTRAAOQ ; EP - Put any comments AFTER the Ask-At-Order Questions
NEW COMMENTS,ERRS,FDA,IENS,LINE
W !
F LINE=1:1 D Q:LINE<1
. D ^XBFMK
. S DIR(0)="FAO^1:75"
. S DIR("A")="COMMENTS:"
. D ^DIR
. I $L($G(X))<1 S LINE=-1 Q
. ;
. S COMMENTS(LINE)=$G(X)
;
Q:$D(COMMENTS)<1
;
S LINE=.9999999
F S LINE=$O(COMMENTS(LINE)) Q:LINE="" D
. S IENS(1)=$O(^LR(LRDFN,"CH",LRIDT,1,"B"),-1)+1 ; Get next COMMENT line
. S FDA(63.041,"+1,"_LRIDT_","_LRDFN_",",.01)=$G(COMMENTS(LINE))
. D UPDATE^DIE(,"FDA","IENS","ERRS")
Q
; ----- END IHS/OIT/MKK - LR*5.2*1030
;
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 X LRDEL 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
LRVER4 ;DALOI/CJS/DALOI/FHS - LAB ROUTINE DATA VERIFICATION ; 13-Oct-2017 14:04 ; MKK
+1 ;;5.2;LAB SERVICE;**14,42,112,121,140,171,153,188,279,283,1018,286,1027,1030,1033,1038,1039,1041**;NOV 01, 1997;Build 23
+2 ;
+3 NEW LRAMEND,LRRFLAG
+4 ;
LOOP ;
+1 ;
+2 SET LRLCT=0
+3 ; IHS/OIT/MKK - LR*5.2*1030
DO UPDTCOML^BLRAAORU(+$GET(LRDFN),+$GET(LRIDT),+$GET(LRODT),+$GET(LRSN))
+4 IF '$DATA(LRGVP)
Begin DoDot:1
+5 IF $DATA(LRWRDS)
SET LRWRD=LRWRDS
+6 ; W !!,PNM," SSN: ",SSN," " S LRLCT=LRLCT+1
+7 ; IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
WRITE !!,PNM," HRCN: ",HRCN," "
SET LRLCT=LRLCT+1
+8 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
+9 ;
+10 WRITE !,"Pat Info: ",$PIECE($GET(^LR(LRDFN,.091)),U)
+11 ; IHS/OIT/MKK -- LR*5.2*1027
WRITE ?34," Sex: "
IF $LENGTH($GET(SEX))
WRITE $SELECT(SEX="M":"MALE",SEX="F":"FEMALE",1:SEX)
+12 ; W ?48," Age: ",$$CALCAGE^LRRPU(DOB,LRCDT)," as of ",$$FMTE^XLFDT(LRCDT,"1D")
+13 ; IHS/OIT/MKK -- LR*5.2*1027
WRITE ?48," Age: ",$$CALCAGE^LRRPU(+$GET(VADM(3)),LRCDT)," as of ",$$FMTE^XLFDT(LRCDT,"1D")
+14 SET LRPRAC=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,8)
+15 IF LRPRAC>0
IF LRPRAC=+LRPRAC
DO GETS^DIQ(200,LRPRAC_",",".01;.132;.137;.138","E","LRPRAC(LRPRAC)","LRERR")
+16 WRITE !,"Provider: "
+17 SET LRLCT=LRLCT+2
+18 IF LRPRAC'=""
IF '$DATA(LRPRAC(LRPRAC,200))
WRITE LRPRAC
+19 IF LRPRAC
IF $DATA(LRPRAC(LRPRAC,200))
Begin DoDot:1
+20 WRITE LRPRAC(LRPRAC,200,LRPRAC_",",.01,"E"),?40," Voice pager: ",LRPRAC(LRPRAC,200,LRPRAC_",",.137,"E")
+21 WRITE !," Phone: ",LRPRAC(LRPRAC,200,LRPRAC_",",.132,"E"),?38," Digital pager: ",LRPRAC(LRPRAC,200,LRPRAC_",",.138,"E")
+22 SET LRLCT=LRLCT+1
End DoDot:1
+23 ;
+24 NEW PRAC,PR
+25 DO PRAC^LR7OMERG(LRAA,LRAD,LRAN,.PRAC)
+26 IF $ORDER(PRAC(0))
Begin DoDot:1
+27 SET PR=0
+28 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
+29 WRITE !
SET LRLCT=LRLCT+1
+30 SET LRNX=0
SET LRVRM=2
SET T=""
+31 IF $PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,7)'=""
Begin DoDot:1
+32 WRITE !,"VOLUME: ",$PIECE(^(0),U,7)
+33 SET LRLCT=LRLCT+1
End DoDot:1
+34 SET LRACC=$PIECE(Z1,U,6)
+35 WRITE !,"ACCESSION:",?30,$PIECE(Z2,U,6),?44," ",LRACC
+36 WRITE !,?30,LRDAT(2)
WRITE ?44," ",LRDAT
+37 SET LRLCT=LRLCT+2
+38 IF $DATA(LRALERT)
IF LRALERT<($PIECE(LRPARAM,U,20)+1)
Begin DoDot:1
+39 WRITE !?15
IF $EXTRACT(IOST,1,2)="C-"
WRITE @LRVIDO
+40 WRITE "Test ordered "_$PIECE($GET(^LAB(62.05,+LRALERT,0)),U)
+41 IF $EXTRACT(IOST,1,2)="C-"
WRITE @LRVIDOF,$CHAR(7)
+42 SET LRLCT=LRLCT+1
End DoDot:1
+43 ;
+44 IF '$ORDER(LRORD(0))
WRITE !!?7,$CHAR(7),"This is not a verifiable test/accession ",!
QUIT
V ; EP
+1 ;
+2 IF $DATA(LRGVP)
DO V20
QUIT
+3 IF ($ORDER(^LR(LRDFN,LRSS,LRIDT,1))=""!('LRVF&$DATA(LRPER)))&'$DATA(LRNUF)
GOTO EDIT
+4 KILL LRNUF
+5 DO V20
DO ND
IF LRVF&'$DATA(X)#2
GOTO V37
IF LREDIT
GOTO EDIT
+6 SET LRTEC=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,2)):$PIECE(^(2),U),1:$SELECT($DATA(LRUSI):LRUSI,1:""))
SET LREDIT=0
V36 ;
+1 ;
+2 IF $DATA(LRGVP)
QUIT
+3 KILL DIR
+4 SET DIR(0)="SAO^E:Edit;C:Comments;W:Workload"
+5 SET DIR("A")="SELECT ('E' to Edit, 'C' for Comments, 'W' Workload): "
+6 DO ^DIR
+7 IF $DATA(DIRUT)
SET X="^"
GOTO V37
+8 SET X=Y
+9 IF $EXTRACT(X)="E"
SET LREDIT=1
SET X=""
+10 KILL LRNC
+11 IF $EXTRACT(X)="C"
SET LRNC=1
DO COM
KILL LRNC
GOTO V36
+12 IF $EXTRACT(X)="W"
Begin DoDot:1
+13 IF $PIECE(LRPARAM,U,14)
IF $PIECE($GET(^LRO(68,LRAA,0)),U,16)
DO STD^LRCAPV
DO EN^LRCAPV
SET LREND=0
QUIT
+14 WRITE !?10," Workload is not activated."
End DoDot:1
GOTO LOOP
+15 SET X=$SELECT(X="@":"",X="":LRTEC,1:X)
SET LRTEC=X
+16 IF '$DATA(^LRO(68,LRAA,1,LRAD,2))
SET ^(2)=""
SET ^(2)=X_U_$PIECE(^(2),U,2,99)
+17 IF LREDIT
GOTO EDIT
V37 ;LEAVE LRVER4, BACK TO LRVER3
QUIT
+1 ;
+2 ;
V20 ;
+1 ;
+2 IF $GET(LRCHG)
DO V21
DO DCOM^LRVERA
QUIT
+3 SET LRNX=$ORDER(LRORD(LRNX))
IF LRNX<1
GOTO V35
DO SUBS
+4 IF '$GET(LRTS)
GOTO V20
+5 IF '$DATA(LRSB(LRSB))
IF '$DATA(^LR(LRDFN,LRSS,LRIDT,LRSB))
GOTO V20
+6 DO V25^LRVER5
+7 ;
+8 IF $DATA(LRGVP)
DO PG
IF $DATA(LRGVP)&($DATA(DTOUT)!$DATA(DUOUT))
QUIT
+9 ;
+10 WRITE !,$PIECE(^LAB(60,+LRTS,0),U)
+11 SET X1=""
+12 IF $DATA(^LR(LRDFN,LRSS,+LRLDT,LRSB))
Begin DoDot:1
+13 SET X1=$PIECE(^(LRSB),U)
SET X=X1
+14 IF $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET"
Begin DoDot:2
+15 SET X=$$EXTERNAL^DILFD(63.04,LRSB,"",X1)
+16 IF X=""
SET X=X1
End DoDot:2
+17 IF X'=""
WRITE ?30,@LRFP
End DoDot:1
+18 SET (X,LRFLG)=""
+19 IF $DATA(LRSB(LRSB))
Begin DoDot:1
+20 NEW LRX
+21 KILL LRNOVER(LRSB)
+22 SET (LRDL,LRX,X)=$PIECE(LRSB(LRSB),U)
+23 SET LREDIT=0
SET LRFLG=$PIECE(LRSB(LRSB),U,2)
+24 IF $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET"
Begin DoDot:2
+25 SET X=$$EXTERNAL^DILFD(63.04,LRSB,"",LRX)
+26 IF X=""
SET X=LRX
End DoDot:2
+27 ;$P(LRNG,U,7)
WRITE ?44," ",@LRFP," ",LRFLG,?56," ",$PIECE($PIECE(LRSB(LRSB),U,5),"!",7)
+28 SET X=LRX
+29 IF X=""!(X="canc")!(X="comment")!(X="pending")
QUIT
+30 SET Y=0
+31 IF LRDEL'=""
SET LRQ=1
XECUTE LRDEL
KILL LRQ
+32 WRITE " "
+33 IF '$DATA(LRQ)
IF $EXTRACT(LRFLG,2)="*"
DO DISPFLG^LRVER4
End DoDot:1
+34 ;
+35 IF $PIECE(X,U)=""
SET $PIECE(LRSB(LRSB),U)=""
+36 IF $PIECE(X,U)'=""
Begin DoDot:1
+37 NEW I,LRX,LRY
+38 SET $PIECE(LRSB(LRSB),U)=X
SET $PIECE(LRSB(LRSB),U,2)=LRFLG
+39 SET LRX=$$TMPSB^LRVER1(LRSB)
SET LRY=$PIECE(LRSB(LRSB),U,3)
+40 FOR I=1:1:$LENGTH(LRX,"!")
IF $PIECE(LRY,"!",I)=""
SET $PIECE(LRY,"!",I)=$PIECE(LRX,"!",I)
+41 SET $PIECE(LRSB(LRSB),U,3)=LRY
+42 IF $PIECE($PIECE(LRSB(LRSB),U,3),"!")=""
DO RONLT^LRVER3
+43 Begin DoDot:2
+44 IF $PIECE(LRSB(LRSB),U,4)!($PIECE(LRSB(LRSB),U)="pending")
QUIT
+45 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
+46 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
+47 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
+48 SET $PIECE(LRSB(LRSB),U,5)=$TRANSLATE(LRNGS,U,"!")
End DoDot:1
+49 IF '$DATA(LRNUF)
SET LRLCT=LRLCT+1
IF $X>80
SET LRLCT=LRLCT+1
IF LRLCT>22
DO WT
IF $GET(Y)'="^"
GOTO V20
+50 ;
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 ; IHS/MSC/MKK - LR*5.2*1041 - Qualitative check
IF $LENGTH($TEXT(QUALCHEK^BLRQUALU))
IF $$QUALCHEK^BLRQUALU()
QUIT
+3 ;
+4 ; IHS/MSC/MKK - LR*5.2*1033
IF X[":"&((LRNG2[":")!(LRNG3[":")!(LRNG4[":")!(LRNG5[":"))
DO IHSCHECK
QUIT
+5 ;
+6 ; IHS/MSC/MKK - LR*5.2*1033
IF $EXTRACT(LRNG2,2)="<"!($EXTRACT(LRNG3,2)=">")!($EXTRACT(LRNG4,2)="<")!($EXTRACT(LRNG5,2)=">")
DO IHSLOGIC
QUIT
+7 ; IHS/MSC/MKK - LR*5.2*1033
IF $EXTRACT(LRNG2,2)=">"!($EXTRACT(LRNG3,2)="<")!($EXTRACT(LRNG4,2)=">")!($EXTRACT(LRNG5,2)="<")
DO IHSLOGIC
QUIT
+8 ;
+9 ; Check for numeric abnormal results
+10 IF X?.1"-".N.1".".N
Begin DoDot:1
+11 IF LRNG4'=""
IF LRNG4?.1"-".N.1".".N
IF X<LRNG4
SET LRFLG="L*"
QUIT
+12 IF LRNG5'=""
IF LRNG5?.1"-".N.1".".N
IF X>LRNG5
SET LRFLG="H*"
QUIT
+13 IF LRNG2'=""
IF LRNG2?.1"-".N.1".".N
IF X<LRNG2
SET LRFLG="L"
QUIT
+14 IF LRNG3'=""
IF LRNG3?.1"-".N.1".".N
IF X>LRNG3
SET LRFLG="H"
QUIT
End DoDot:1
QUIT
+15 ;
+16 ; Check for <> abnormal results
+17 ; "<" results checked against low values
+18 ; ">" results checked against high values
+19 IF X?1(1"<",1">").N.1".".N
Begin DoDot:1
+20 NEW LRX
+21 SET LRX=$EXTRACT(X,2,$LENGTH(X))
+22 IF $EXTRACT(X)="<"
Begin DoDot:2
+23 IF LRNG4'=""
IF LRNG4?.N.1".".N
IF LRX<LRNG4
SET LRFLG="L*"
QUIT
+24 IF LRNG4'=""
IF LRNG4?.N.1".".N
IF LRX=LRNG4
SET LRFLG="L*"
QUIT
+25 IF LRNG2'=""
IF LRNG2?.N.1".".N
IF LRX<LRNG2
SET LRFLG="L"
QUIT
+26 IF LRNG2'=""
IF LRNG2?.N.1".".N
IF LRX=LRNG2
SET LRFLG="L"
QUIT
End DoDot:2
QUIT
+27 IF $EXTRACT(X)=">"
Begin DoDot:2
+28 IF LRNG5'=""
IF LRNG5?.N.1".".N
IF LRX>LRNG5
SET LRFLG="H*"
QUIT
+29 IF LRNG5'=""
IF LRNG5?.N.1".".N
IF LRX=LRNG5
SET LRFLG="H*"
QUIT
+30 IF LRNG3'=""
IF LRNG3?.N.1".".N
IF LRX>LRNG3
SET LRFLG="H"
QUIT
+31 IF LRNG3'=""
IF LRNG3?.N.1".".N
IF LRX=LRNG3
SET LRFLG="H"
QUIT
End DoDot:2
QUIT
End DoDot:1
QUIT
+32 ;
+33 ; Check for ranges, i.e. 0-5, 6-10.
+34 ; Compare first value to abnormal value
+35 IF X?1.N1"-"1.N
Begin DoDot:1
+36 IF LRNG4'=""
IF LRNG4?.N.1".".N
IF +X<LRNG4
SET LRFLG="L*"
QUIT
+37 IF LRNG5'=""
IF LRNG5?.N.1".".N
IF +X>LRNG5
SET LRFLG="H*"
QUIT
+38 IF LRNG2'=""
IF LRNG2?.N.1".".N
IF +X<LRNG2
SET LRFLG="L"
QUIT
+39 IF LRNG3'=""
IF LRNG3?.N.1".".N
IF +X>LRNG3
SET LRFLG="H"
QUIT
End DoDot:1
QUIT
+40 ;
+41 QUIT
+42 ;
+43 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+44 ; Special logic for Titer results
IHSCHECK ; EP
+1 NEW RESULT,CHEK
+2 ;
+3 ; If no result, skip
SET RESULT=$PIECE(X,":",2)
IF $LENGTH(RESULT)<1
QUIT
+4 ;
+5 SET CHEK=$PIECE(LRNG4,":",2)
IF $LENGTH(CHEK)
IF RESULT<CHEK
SET LRFLG="L*"
QUIT
+6 SET CHEK=$PIECE(LRNG5,":",2)
IF $LENGTH(CHEK)
IF RESULT>CHEK
SET LRFLG="H*"
QUIT
+7 SET CHEK=$PIECE(LRNG2,":",2)
IF $LENGTH(CHEK)
IF RESULT<CHEK
SET LRFLG="L"
QUIT
+8 SET CHEK=$PIECE(LRNG3,":",2)
IF $LENGTH(CHEK)
IF RESULT>CHEK
SET LRFLG="H"
QUIT
+9 QUIT
+10 ;
+11 ; Special logic for Ref Range beginning with > or < symbol
IHSLOGIC ; EP
+1 NEW IHSLRNG2,IHSLRNG3,IHSLRNG4,IHSLRNG5
+2 ;
+3 SET (IHSLRNG2,IHSLRNG3,IHSLRNG4,IHSLRNG5)=""
+4 ;
+5 IF $EXTRACT(LRNG2,2)="<"
DO IHSRLOW(LRNG2,.IHSLRNG2)
+6 IF $EXTRACT(LRNG2,2)=">"
DO IHSHIGH(LRNG2,.IHSLRNG2)
+7 IF $EXTRACT(LRNG3,2)="<"
DO IHSRLOW(LRNG3,.IHSLRNG3)
+8 IF $EXTRACT(LRNG3,2)=">"
DO IHSHIGH(LRNG3,.IHSLRNG3)
+9 IF $EXTRACT(LRNG4,2)="<"
DO IHSRLOW(LRNG4,.IHSLRNG4)
+10 IF $EXTRACT(LRNG4,2)=">"
DO IHSHIGH(LRNG4,.IHSLRNG4)
+11 IF $EXTRACT(LRNG5,2)="<"
DO IHSRLOW(LRNG5,.IHSLRNG5)
+12 IF $EXTRACT(LRNG5,2)=">"
DO IHSHIGH(LRNG5,.IHSLRNG5)
+13 ;
+14 IF IHSLRNG4'=""
IF IHSLRNG4?.1"-".N.1".".N
IF X<IHSLRNG4
SET LRFLG="L*"
QUIT
+15 IF IHSLRNG5'=""
IF IHSLRNG5?.1"-".N.1".".N
IF X>IHSLRNG5
SET LRFLG="H*"
QUIT
+16 IF IHSLRNG2'=""
IF IHSLRNG2?.1"-".N.1".".N
IF X<IHSLRNG2
SET LRFLG="L"
QUIT
+17 IF IHSLRNG3'=""
IF IHSLRNG3?.1"-".N.1".".N
IF X>IHSLRNG3
SET LRFLG="H"
QUIT
+18 QUIT
+19 ;
IHSRLOW(LRNG,IHSRNG) ; EP - Reset low
+1 NEW NUMDEC,SUBTRACT
+2 SET SUBTRACT=1
+3 SET NUMDEC=$LENGTH($PIECE(LRNG,".",2))
+4 IF NUMDEC
SET SUBTRACT="."_$TRANSLATE($JUSTIFY("",NUMDEC)," ","0")_"1"
+5 SET IHSRNG=$PIECE($PIECE(LRNG,"<",2)," ")-SUBTRACT
+6 QUIT
+7 ;
IHSHIGH(LRNG,IHSRNG) ; EP - Reset High
+1 NEW NUMDEC,ADDON
+2 SET ADDON=1
+3 SET NUMDEC=$LENGTH($PIECE(LRNG,".",2))
+4 IF NUMDEC
SET ADDON="."_$TRANSLATE($JUSTIFY("",NUMDEC)," ","0")_"1"
+5 SET IHSRNG=$PIECE($PIECE(LRNG,">",2)," ")+ADDON
+6 QUIT
+7 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+8 ;
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 ;
+7 ; S DIR(0)="FO"
+8 ; S DIR("A")="If you need to change something, enter your initials"
+9 ; S DIR("?")="To change verified results, enter your initials."
+10 ; D ^DIR
+11 ; S X=Y K DIR
+12 ;
+13 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038 -- Mask User input.
+14 ; DO Statement used to ensure variables ANSWER, STEP, & TEXT are strictly local
Begin DoDot:1
+15 NEW ANSWER,STEP,TEXT
+16 KILL X
+17 WRITE !,"If you need to change something, enter your initials: "
+18 SET ANSWER=""
+19 ; F STEP=1:1:4 R TEXT#1 S:TEXT="^" ANSWER="^" Q:TEXT="^"!(TEXT="") S ANSWER=ANSWER_TEXT W $C(8),"*"
+20 ; IHS/MSC/MKK - LR*5.2*1039
FOR STEP=1:1:6
READ TEXT#1
IF TEXT="^"
SET ANSWER="^"
IF TEXT="^"!(TEXT="")
QUIT
SET ANSWER=ANSWER_TEXT
WRITE $CHAR(8),"*"
+21 SET LRINI=ANSWER
+22 SET X=ANSWER
End DoDot:1
+23 ; ----- END IHS/MSC/MKK - LR*5.2*1038
+24 ;
+25 IF $$UP^XLFSTR(X)'=$$UP^XLFSTR(LRUSI)
SET LREDIT=0
KILL X
QUIT
+26 IF $DATA(X)#2
IF '$GET(LRCHG)
WRITE !
Begin DoDot:1
+27 KILL LRSA
SET LRSA=1
+28 FOR
SET LRSA=$ORDER(^LR(LRDFN,"CH",LRIDT,LRSA))
IF 'LRSA
QUIT
SET LRSA(LRSA)=^(LRSA)
End DoDot:1
SET LRCHG=1
+29 QUIT
+30 ;
+31 ;
WT ; EP
+1 SET LRLCT=0
IF $DATA(LRGVP)
QUIT
+2 WRITE !,"PRESS ANY KEY TO CONTINUE, '^' TO STOP "
READ Y:DTIME
IF '$TEST
SET Y="^"
+3 QUIT
+4 ;
+5 ;
COM ;from LRVER5
+1 IF $DATA(LRGVP)
QUIT
+2 ;
+3 ; IHS/OIT/MKK - LR*5.2*1030
IF $GET(^LR(LRDFN,"CH",LRIDT,1,1,0))["ASK AT ORDER"
DO AFTRAAOQ
QUIT
+4 ; IHS/MSC/MKK - LR*5.2*1033
DO GETCCDTA^BLRCCPED(LRDFN,"CH",LRIDT)
+5 ;
+6 KILL DR
+7 SET DIE="^LR("_LRDFN_",""CH"","
SET DA=LRIDT
SET DA(1)=LRDFN
SET DR=.99
+8 DO ^DIE
IF $DATA(LRNC)
DO COM1
+9 LOCK +^LR(LRDFN,LRSS,LRIDT):5
+10 IF $ORDER(^LR(LRDFN,"CH",LRIDT,1,0))=""
KILL ^LR(LRDFN,"CH",LRIDT,1)
+11 LOCK -^LR(LRDFN,LRSS,LRIDT)
+12 QUIT
+13 ;
+14 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
AFTRAAOQ ; EP - Put any comments AFTER the Ask-At-Order Questions
+1 NEW COMMENTS,ERRS,FDA,IENS,LINE
+2 WRITE !
+3 FOR LINE=1:1
Begin DoDot:1
+4 DO ^XBFMK
+5 SET DIR(0)="FAO^1:75"
+6 SET DIR("A")="COMMENTS:"
+7 DO ^DIR
+8 IF $LENGTH($GET(X))<1
SET LINE=-1
QUIT
+9 ;
+10 SET COMMENTS(LINE)=$GET(X)
End DoDot:1
IF LINE<1
QUIT
+11 ;
+12 IF $DATA(COMMENTS)<1
QUIT
+13 ;
+14 SET LINE=.9999999
+15 FOR
SET LINE=$ORDER(COMMENTS(LINE))
IF LINE=""
QUIT
Begin DoDot:1
+16 ; Get next COMMENT line
SET IENS(1)=$ORDER(^LR(LRDFN,"CH",LRIDT,1,"B"),-1)+1
+17 SET FDA(63.041,"+1,"_LRIDT_","_LRDFN_",",.01)=$GET(COMMENTS(LINE))
+18 DO UPDATE^DIE(,"FDA","IENS","ERRS")
End DoDot:1
+19 QUIT
+20 ; ----- END IHS/OIT/MKK - LR*5.2*1030
+21 ;
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
XECUTE LRDEL
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
