LRMIV2 ;SLC/DLG - MICROBIOLOGY VERIFY AUTO INST ROUTINE ;3/2/03 18:09
;;5.2;LAB SERVICE;**242,295**;Sep 27, 1994
;from LRFAST,LRMIV,LRVER
PAT S X=LRAN
F I=0:0 R:'$D(LRAN) !!,"Accession #: ",X:DTIME Q:X=""!(X[U) S LRANOK=1,LRCAPOK=1 D LRANX^LRMIU4 D:LRANOK PAT1,CAP K:LRANOK LRAN I 'LRANOK W !,"Enter the accession number" K LRAN
Q
CAP I LRCAPOK,LRANOK,$P(LRPARAM,U,14),$P($G(^LRO(68,LRAA,0)),U,16) D LOOK^LRCAPV1 Q
PAT1 ;
S LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRIDT=9999999-^(3),LRCDT=+^(3),LREAL=$P(^(3),U,2),LRI=+$O(^(5,0)),LRSPEC=$S($D(^(LRI,0)):+^(0),1:"")
I $D(^LR(LRDFN,"MI",LRIDT,0)) S Y(0)=^(0)
I '$D(^LR(LRDFN,"MI",LRIDT,0)) D BB
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRUNDO=0 D PT^LRX W ?25," ",PNM,?47," ",SSN
I $P(^LR(LRDFN,"MI",LRIDT,0),U,3) W !,"Final report has been verified by microbiology supervisor.",$C(7),!,"If you proceed in editing, this report will need to be reverified."
F I=0:0 W !,?20,"OK" S %=1 D YN^DICN Q:% W !,"Enter 'Y' or 'N':"
I %=2!(%<0) S LRCAPOK=0 Q
I $P(^LR(LRDFN,"MI",LRIDT,0),U,3)!$P(^LR(LRDFN,"MI",LRIDT,0),U,9) S LRUNDO=1 ;W:$P(^(0),U,9) !,"(This is an AMENDED report)",!
F I=0:0 D EC Q:$D(LRNPTP) W:N=0 !,"NO TESTS ON WORKLIST" Q:N=0 S LRI=1 Q:N'>1 R !,"Choose: ",LRI:DTIME Q:LRI[U!(LRI="") S LRI=+LRI I LRI>0,LRI'>N,LRI?1N.N Q
I LRI[U!(LRI="") S LRCAPOK=0 Q
S LRTS=LRTS(LRI) D:LRUNDO UNDO^LRMIV
K DR S DA=LRIDT,DA(1)=LRDFN,DIE="^LR(LRDFN,""MI"","
S LRSB=$S(LRTX(LRI)["11.5":1,LRTX(LRI)["15":5,LRTX(LRI)["19":8,LRTX(LRI)["23":11,LRTX(LRI)["34":16,1:""),LRFIFO=LRTX(LRI)["FIFO",(LREND,LRSAME)=0 D:'LRFIFO TIME^LRMIV3 I LREND K DR Q
S LRSSC=$P(^LR(LRDFN,"MI",LRIDT,0),U,5)_U_$P(^(0),U,11)
I LRTX(LRI)'["S DR=""[" X LRTX(LRI) D UPDATE^LRPXRM(LRDFN,"MI",LRIDT) D:'LREND EC3 K DR Q
S (X,DR)=$P($P(LRTX(LRI),"[",2),"]",1) S:$L(X) X=+$O(^DIE("B",X,0)) I X<1,'$D(^DIE(X,"DR",2,63.05)) W !,DR," template doesn't exist for Microbiology." K DR Q
S J=1 F I=0:0 S J=+$O(^DIE(X,"DR",J)) Q:J<1 S K=+$O(^DIE(X,"DR",J,0)),DR(J-1,K)=^DIE(X,"DR",J,K)
S DR=DR(1,63.05) D ^DIE,UPDATE^LRPXRM(LRDFN,"MI",LRIDT),EC3 K DR
Q
BB I '$D(^LR(LRDFN,"MI",0)) S ^LR(LRDFN,"MI",0)="^63.05DA^"
S ^LR(LRDFN,"MI",0)=$P(^LR(LRDFN,"MI",0),U,1,2)_U_LRIDT_U_(1+$P(^(0),U,4))
S ^LR(LRDFN,"MI",LRIDT,0)=LRCDT_U_LREAL_"^^^"_LRSPEC_U_$P(^LRO(68,LRAA,0),U,11)_" "_$E(LRAD,2,3)_" "_LRAN_"^^UNKNOWN",Y(0)=^(0)
Q
EC K LRTX S LRAN=$P($P(Y(0),U,6)," ",3),LRLLOC=$P(Y(0),U,8)
S LRODT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4),LRSN=$P(^(0),U,5) I $D(^LRO(69,+LRODT,1,+LRSN,0)) S DIC="^LRO(69,"_LRODT_",1,",DA=LRSN,DR=6 D:DA>0 EN^DIQ S:$D(DTOUT)!($D(DUOUT)) LREND=1 Q:LREND
K LRNPTP S N=0
S LRI=0 F S LRI=+$O(^LRO(68,LRAA,1,LRAD,1,+LRAN,4,LRI)) Q:LRI<.5 S N=N+1,LRTS(N)=+^(LRI,0),LRTX(N)=$S($L($P(^LAB(60,LRTS(N),0),U,14)):^LAB(62.07,$P(^(0),U,14),.1),1:"W !,""EDIT CODE IN FILE 60 NOT DEFINED.""") I LRTS(N)=LRPTP S LRNPTP=N Q
I '$D(LRNPTP),LRPTP>0 W !,"Nothing matches with the test you preselected." Q
I $D(LRNPTP) S LRI=LRNPTP
I '$D(LRNPTP),N>0 F J=1:1:N W !,?3,J,?8,$P(^LAB(60,LRTS(J),0),U) S Y=$P(^LRO(68,LRAA,1,LRAD,1,+LRAN,4,LRTS(J),0),U,5) D:Y>0 DD^LRX W:Y'="" " completed ",Y
Q
EC3 S LRSSCN=$P(^LR(LRDFN,"MI",LRIDT,0),U,5)_U_$P(^(0),U,11) D:LRSSCN'=LRSSC UPDATE K LRSSCN,LRSSC S LRSAME=1 D TIME^LRMIV3 D:'LREND STF^LRMIUT
Q
UPDATE D CHECK K LRSSCOM,LRSSCOM1,LRSSCA,LRSSCAA,LRSSCAY,LRSSCAN,LRSSCOD,LRSSCON
Q
CHECK S LRSSCA=$P(^LR(LRDFN,"MI",LRIDT,0),U,6),LRSSCAA=+$O(^LRO(68,"B",$P(LRSSCA," "),0))
S X=$P(LRSSCA," ",2) D ^%DT S LRSSCAY=Y,LRSSCAN=$P(LRSSCA," ",3)
S J=0 F I=0:0 S J=+$O(^LRO(68,LRSSCAA,1,LRSSCAY,1,LRSSCAN,5,J)) Q:J<1 I ^(J,0)=LRSSC S ^(0)=LRSSCN Q
I J<1 Q
S LRSSCOD=$P(^LRO(68,LRSSCAA,1,LRSSCAY,1,LRSSCAN,0),U,4),LRSSCON=^(.1)
S J=0 F I=0:0 S J=+$O(^LRO(69,LRSSCOD,1,J)) Q:J<1 I $D(^(J,.1)),^(.1)=LRSSCON D ORDER Q
Q
ORDER S $P(^LRO(69,LRSSCOD,1,J,0),U,3)=$P(LRSSCN,U,2)
S K=0 F I=0:0 S K=+$O(^LRO(69,LRSSCOD,1,J,4,K)) Q:K<1 I ^(K,0)=LRSSC S ^(0)=LRSSCN Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMIV2 3988 printed Apr 09, 2024@21:05:39 Page 2
LRMIV2 ;SLC/DLG - MICROBIOLOGY VERIFY AUTO INST ROUTINE ;3/2/03 18:09
+1 ;;5.2;LAB SERVICE;**242,295**;Sep 27, 1994
+2 ;from LRFAST,LRMIV,LRVER
PAT SET X=LRAN
+1 FOR I=0:0
if '$DATA(LRAN)
READ !!,"Accession #: ",X:DTIME
if X=""!(X[U)
QUIT
SET LRANOK=1
SET LRCAPOK=1
DO LRANX^LRMIU4
if LRANOK
DO PAT1
DO CAP
if LRANOK
KILL LRAN
IF 'LRANOK
WRITE !,"Enter the accession number"
KILL LRAN
+2 QUIT
CAP IF LRCAPOK
IF LRANOK
IF $PIECE(LRPARAM,U,14)
IF $PIECE($GET(^LRO(68,LRAA,0)),U,16)
DO LOOK^LRCAPV1
QUIT
PAT1 ;
+1 SET LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRIDT=9999999-^(3)
SET LRCDT=+^(3)
SET LREAL=$PIECE(^(3),U,2)
SET LRI=+$ORDER(^(5,0))
SET LRSPEC=$SELECT($DATA(^(LRI,0)):+^(0),1:"")
+2 IF $DATA(^LR(LRDFN,"MI",LRIDT,0))
SET Y(0)=^(0)
+3 IF '$DATA(^LR(LRDFN,"MI",LRIDT,0))
DO BB
+4 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
SET LRUNDO=0
DO PT^LRX
WRITE ?25," ",PNM,?47," ",SSN
+5 IF $PIECE(^LR(LRDFN,"MI",LRIDT,0),U,3)
WRITE !,"Final report has been verified by microbiology supervisor.",$CHAR(7),!,"If you proceed in editing, this report will need to be reverified."
+6 FOR I=0:0
WRITE !,?20,"OK"
SET %=1
DO YN^DICN
if %
QUIT
WRITE !,"Enter 'Y' or 'N':"
+7 IF %=2!(%<0)
SET LRCAPOK=0
QUIT
+8 ;W:$P(^(0),U,9) !,"(This is an AMENDED report)",!
IF $PIECE(^LR(LRDFN,"MI",LRIDT,0),U,3)!$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,9)
SET LRUNDO=1
+9 FOR I=0:0
DO EC
if $DATA(LRNPTP)
QUIT
if N=0
WRITE !,"NO TESTS ON WORKLIST"
if N=0
QUIT
SET LRI=1
if N'>1
QUIT
READ !,"Choose: ",LRI:DTIME
if LRI[U!(LRI="")
QUIT
SET LRI=+LRI
IF LRI>0
IF LRI'>N
IF LRI?1N.N
QUIT
+10 IF LRI[U!(LRI="")
SET LRCAPOK=0
QUIT
+11 SET LRTS=LRTS(LRI)
if LRUNDO
DO UNDO^LRMIV
+12 KILL DR
SET DA=LRIDT
SET DA(1)=LRDFN
SET DIE="^LR(LRDFN,""MI"","
+13 SET LRSB=$SELECT(LRTX(LRI)["11.5":1,LRTX(LRI)["15":5,LRTX(LRI)["19":8,LRTX(LRI)["23":11,LRTX(LRI)["34":16,1:"")
SET LRFIFO=LRTX(LRI)["FIFO"
SET (LREND,LRSAME)=0
if 'LRFIFO
DO TIME^LRMIV3
IF LREND
KILL DR
QUIT
+14 SET LRSSC=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,5)_U_$PIECE(^(0),U,11)
+15 IF LRTX(LRI)'["S DR=""["
XECUTE LRTX(LRI)
DO UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
if 'LREND
DO EC3
KILL DR
QUIT
+16 SET (X,DR)=$PIECE($PIECE(LRTX(LRI),"[",2),"]",1)
if $LENGTH(X)
SET X=+$ORDER(^DIE("B",X,0))
IF X<1
IF '$DATA(^DIE(X,"DR",2,63.05))
WRITE !,DR," template doesn't exist for Microbiology."
KILL DR
QUIT
+17 SET J=1
FOR I=0:0
SET J=+$ORDER(^DIE(X,"DR",J))
if J<1
QUIT
SET K=+$ORDER(^DIE(X,"DR",J,0))
SET DR(J-1,K)=^DIE(X,"DR",J,K)
+18 SET DR=DR(1,63.05)
DO ^DIE
DO UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
DO EC3
KILL DR
+19 QUIT
BB IF '$DATA(^LR(LRDFN,"MI",0))
SET ^LR(LRDFN,"MI",0)="^63.05DA^"
+1 SET ^LR(LRDFN,"MI",0)=$PIECE(^LR(LRDFN,"MI",0),U,1,2)_U_LRIDT_U_(1+$PIECE(^(0),U,4))
+2 SET ^LR(LRDFN,"MI",LRIDT,0)=LRCDT_U_LREAL_"^^^"_LRSPEC_U_$PIECE(^LRO(68,LRAA,0),U,11)_" "_$EXTRACT(LRAD,2,3)_" "_LRAN_"^^UNKNOWN"
SET Y(0)=^(0)
+3 QUIT
EC KILL LRTX
SET LRAN=$PIECE($PIECE(Y(0),U,6)," ",3)
SET LRLLOC=$PIECE(Y(0),U,8)
+1 SET LRODT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
SET LRSN=$PIECE(^(0),U,5)
IF $DATA(^LRO(69,+LRODT,1,+LRSN,0))
SET DIC="^LRO(69,"_LRODT_",1,"
SET DA=LRSN
SET DR=6
if DA>0
DO EN^DIQ
if $DATA(DTOUT)!($DATA(DUOUT))
SET LREND=1
if LREND
QUIT
+2 KILL LRNPTP
SET N=0
+3 SET LRI=0
FOR
SET LRI=+$ORDER(^LRO(68,LRAA,1,LRAD,1,+LRAN,4,LRI))
if LRI<.5
QUIT
SET N=N+1
SET LRTS(N)=+^(LRI,0)
SET LRTX(N)=$SELECT($LENGTH($PIECE(^LAB(60,LRTS(N),0),U,14)):^LAB(62.07,$PIECE(^(0),U,14),.1),1:"W !,""EDIT CODE IN FILE 60 NOT DEFINED.""")
IF LRTS(N)=LRPTP
SET LRNPTP=N
QUIT
+4 IF '$DATA(LRNPTP)
IF LRPTP>0
WRITE !,"Nothing matches with the test you preselected."
QUIT
+5 IF $DATA(LRNPTP)
SET LRI=LRNPTP
+6 IF '$DATA(LRNPTP)
IF N>0
FOR J=1:1:N
WRITE !,?3,J,?8,$PIECE(^LAB(60,LRTS(J),0),U)
SET Y=$PIECE(^LRO(68,LRAA,1,LRAD,1,+LRAN,4,LRTS(J),0),U,5)
if Y>0
DO DD^LRX
if Y'=""
WRITE " completed ",Y
+7 QUIT
EC3 SET LRSSCN=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,5)_U_$PIECE(^(0),U,11)
if LRSSCN'=LRSSC
DO UPDATE
KILL LRSSCN,LRSSC
SET LRSAME=1
DO TIME^LRMIV3
if 'LREND
DO STF^LRMIUT
+1 QUIT
UPDATE DO CHECK
KILL LRSSCOM,LRSSCOM1,LRSSCA,LRSSCAA,LRSSCAY,LRSSCAN,LRSSCOD,LRSSCON
+1 QUIT
CHECK SET LRSSCA=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,6)
SET LRSSCAA=+$ORDER(^LRO(68,"B",$PIECE(LRSSCA," "),0))
+1 SET X=$PIECE(LRSSCA," ",2)
DO ^%DT
SET LRSSCAY=Y
SET LRSSCAN=$PIECE(LRSSCA," ",3)
+2 SET J=0
FOR I=0:0
SET J=+$ORDER(^LRO(68,LRSSCAA,1,LRSSCAY,1,LRSSCAN,5,J))
if J<1
QUIT
IF ^(J,0)=LRSSC
SET ^(0)=LRSSCN
QUIT
+3 IF J<1
QUIT
+4 SET LRSSCOD=$PIECE(^LRO(68,LRSSCAA,1,LRSSCAY,1,LRSSCAN,0),U,4)
SET LRSSCON=^(.1)
+5 SET J=0
FOR I=0:0
SET J=+$ORDER(^LRO(69,LRSSCOD,1,J))
if J<1
QUIT
IF $DATA(^(J,.1))
IF ^(.1)=LRSSCON
DO ORDER
QUIT
+6 QUIT
ORDER SET $PIECE(^LRO(69,LRSSCOD,1,J,0),U,3)=$PIECE(LRSSCN,U,2)
+1 SET K=0
FOR I=0:0
SET K=+$ORDER(^LRO(69,LRSSCOD,1,J,4,K))
if K<1
QUIT
IF ^(K,0)=LRSSC
SET ^(0)=LRSSCN
QUIT
+2 QUIT
