- LRMIV2 ;VA/SLC/DLG - MICROBIOLOGY VERIFY AUTO INST ROUTINE ;3/2/03 18:09
- ;;5.2;LAB SERVICE;**1030,1031**;NOV 01, 1997
- ;
- ;;VA LR Patche(s): 242,295
- ;
- ;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
- S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRUNDO=0 D PT^LRX W ?25," ",PNM,?47," ",HRCN ; IHS/OIT/MKK - LR*5.2*1030
- 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
- ; I LRTX(LRI)'["S DR=""[" X LRTX(LRI) D:'LREND EC3 K DR Q ; IHS/OIT/MKK - LR*5.2*1030 - RPMS Does NOT use Clinical Reminders
- I '$$PATCH^BLRUTIL4("PXRM*1.5*12") I LRTX(LRI)'["S DR=""[" X LRTX(LRI) D:'LREND EC3 K DR Q ; IHS/MSC/MKK - LR*5.2*1031
- I $$PATCH^BLRUTIL4("PXRM*1.5*12") I LRTX(LRI)'["S DR=""[" X LRTX(LRI) D UPDATE^LRPXRM(LRDFN,"MI",LRIDT) D:'LREND EC3 K DR Q ; IHS/MSC/MKK - LR*5.2*1031
- 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
- ; S DR=DR(1,63.05) D ^DIE,EC3 K DR ; IHS/OIT/MKK - LR*5.2*1030 - RPMS Does NOT use Clinical Reminders
- I '$$PATCH^BLRUTIL4("PXRM*1.5*12") S DR=DR(1,63.05) D ^DIE,EC3 K DR ; IHS/MSC/MKK - LR*5.2*1031
- I $$PATCH^BLRUTIL4("PXRM*1.5*12") S DR=DR(1,63.05) D ^DIE,UPDATE^LRPXRM(LRDFN,"MI",LRIDT),EC3 K DR ; IHS/MSC/MKK - LR*5.2*1031
- 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
- LRMIV2 ;VA/SLC/DLG - MICROBIOLOGY VERIFY AUTO INST ROUTINE ;3/2/03 18:09
- +1 ;;5.2;LAB SERVICE;**1030,1031**;NOV 01, 1997
- +2 ;
- +3 ;;VA LR Patche(s): 242,295
- +4 ;
- +5 ;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 ; S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRUNDO=0 D PT^LRX W ?25," ",PNM,?47," ",SSN
- +5 ; IHS/OIT/MKK - LR*5.2*1030
- SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- SET LRUNDO=0
- DO PT^LRX
- WRITE ?25," ",PNM,?47," ",HRCN
- +6 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."
- +7 FOR I=0:0
- WRITE !,?20,"OK"
- SET %=1
- DO YN^DICN
- IF %
- QUIT
- WRITE !,"Enter 'Y' or 'N':"
- +8 IF %=2!(%<0)
- SET LRCAPOK=0
- QUIT
- +9 ;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
- +10 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
- +11 IF LRI[U!(LRI="")
- SET LRCAPOK=0
- QUIT
- +12 SET LRTS=LRTS(LRI)
- IF LRUNDO
- DO UNDO^LRMIV
- +13 KILL DR
- SET DA=LRIDT
- SET DA(1)=LRDFN
- SET DIE="^LR(LRDFN,""MI"","
- +14 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
- +15 SET LRSSC=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,5)_U_$PIECE(^(0),U,11)
- +16 ; I LRTX(LRI)'["S DR=""[" X LRTX(LRI) D UPDATE^LRPXRM(LRDFN,"MI",LRIDT) D:'LREND EC3 K DR Q
- +17 ; I LRTX(LRI)'["S DR=""[" X LRTX(LRI) D:'LREND EC3 K DR Q ; IHS/OIT/MKK - LR*5.2*1030 - RPMS Does NOT use Clinical Reminders
- +18 ; IHS/MSC/MKK - LR*5.2*1031
- IF '$$PATCH^BLRUTIL4("PXRM*1.5*12")
- IF LRTX(LRI)'["S DR=""["
- XECUTE LRTX(LRI)
- IF 'LREND
- DO EC3
- KILL DR
- QUIT
- +19 ; IHS/MSC/MKK - LR*5.2*1031
- IF $$PATCH^BLRUTIL4("PXRM*1.5*12")
- IF LRTX(LRI)'["S DR=""["
- XECUTE LRTX(LRI)
- DO UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
- IF 'LREND
- DO EC3
- KILL DR
- QUIT
- +20 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
- +21 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)
- +22 ; S DR=DR(1,63.05) D ^DIE,UPDATE^LRPXRM(LRDFN,"MI",LRIDT),EC3 K DR
- +23 ; S DR=DR(1,63.05) D ^DIE,EC3 K DR ; IHS/OIT/MKK - LR*5.2*1030 - RPMS Does NOT use Clinical Reminders
- +24 ; IHS/MSC/MKK - LR*5.2*1031
- IF '$$PATCH^BLRUTIL4("PXRM*1.5*12")
- SET DR=DR(1,63.05)
- DO ^DIE
- DO EC3
- KILL DR
- +25 ; IHS/MSC/MKK - LR*5.2*1031
- IF $$PATCH^BLRUTIL4("PXRM*1.5*12")
- SET DR=DR(1,63.05)
- DO ^DIE
- DO UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
- DO EC3
- KILL DR
- +26 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
