LR7OC0 ;slc/dcm - Convert orders from old to new format ;8/11/97
;;5.2;LAB SERVICE;**121,187**;Sep 27, 1994
;
EN ;For a good time, enter here. Lab order conversion with KIDS.
I $$VER^LR7OU1<3 Q ;OE/RR 2.5 Check
S ZTDTH=$H,ZTIO="",ZTRTN="EN1^LR7OC0" D ^%ZTLOAD
Q
EN1 ;Convert orders without KIDS
I $$VER^LR7OU1<3 Q ;OE/RR 2.5 Check
Q:$G(^ORD(100.99,1,"CONV"))
N LRORD,LRODT,LRSN,TST,LR1,X,SUBHEAD
S LRORD=$S($G(^LRO(69,"LRORD CONV",0)):+^(0),1:0) D:'LRORD CK
F S LRORD=$O(^LRO(69,"C",LRORD)) Q:LRORD<1 L +^LRCNVRT(LRORD):9999 D L -^LRCNVRT(LRORD)
. S LRODT=0 F S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 S LRSN=0 F S LRSN=$O(^LRO(69,"C",LRORD,LRODT,LRSN)) Q:LRSN<1 I $D(^LRO(69,LRODT,1,LRSN,0)),'$P(^(0),"^",11) D
.. D NEW1^LR7OB0(LRODT,LRSN,"ZC")
.. S $P(^LRO(69,LRODT,1,LRSN,0),"^",11)=1.69
. S ^LRO(69,"LRORD CONV",0)=LRORD
D NOW^%DTC S Y=% X ^DD("DD")
K ^LRO(69,"LRORD CONV",0)
S X(1)="Conversion of lab orders for patch LR*5.2*121 completed: "_Y
S X(2)="Task #"_$G(ZTSK)
D BULL(.X,"Lab Conversion")
I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
Q
CHK ;Check that all lab orders were converted.
N LRORD,LRODT,LRSN,TST,LINK,X0
S LRORD=0
F S LRORD=$O(^LRO(69,"C",LRORD)) Q:LRORD<1 D
. S LRODT=0 F S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 S LRSN=0 F S LRSN=$O(^LRO(69,"C",LRORD,LRODT,LRSN)) Q:LRSN<1 I $D(^LRO(69,LRODT,1,LRSN,0)) S X0=^(0) I $D(^LR(+X0,0)),$P(^(0),"^",2)=2 D
.. S TST=0 F S TST=$O(^LRO(69,LRODT,1,LRSN,2,TST)) Q:TST<1 S T0=^(TST,0) I $P(T0,"^",7),'$P(T0,"^",11),'$P(T0,"^",14) D
... ;I '$P(X0,"^",6),$P(T0,"^",7),$D(^OR(100,$P(T0,"^",7),0)),$P(^(0),"^",4) S X=$P(^(0),"^",4),$P(^LRO(69,LRODT,1,LRSN,0),"^",6)=X,$P(X0,"^",6)=X
... I $P(T0,"^",7),$D(^OR(100,$P(T0,"^",7),0)),$G(^(4))["^" D
.... S X=$P($G(^OR(100,$P(T0,"^",7),3)),"^",3) I X=""!(X=1)!(X=2)!(X=14) Q
.... W !,"NOT CNVRTD-ODT:"_LRODT_" SN:"_LRSN_" ORIFN:"_$P(T0,"^",7)_$S('$P(X0,"^",6):" No Provider",1:"") S ORX4=^(4),ORIFN=$P(T0,"^",7)
Q
CK1 ;Check please (more validity checking). Find bad/missing ptrs to OE/RR 3.0
N LRORD,LRODT,LRSN,TST,ORIFN
S LRORD=0
F S LRORD=$O(^LRO(69,"C",LRORD)) Q:LRORD<1 D
. S LRODT=0 F S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 S LRSN=0 F S LRSN=$O(^LRO(69,"C",LRORD,LRODT,LRSN)) Q:LRSN<1 I $D(^LRO(69,LRODT,1,LRSN,0)) S X=^(0),ORIFN=$P(X,"^",11) I $D(^LR(+X,0)),$P(^(0),"^",2)=2 D
.. I '$L(ORIFN),$O(^LRO(69,LRODT,1,LRSN,2,0)) W !,"Missing ptr at LRSN level to 100:LRODT:"_LRODT_" LRSN:"_LRSN Q
.. I ORIFN,ORIFN'=1.69 D
... I '$D(^OR(100,ORIFN,0)) W !,"Bad ptr to 100:"_X_" LRODT:"_LRODT_" LRSN:"_LRSN
... S TST=0 F S TST=$O(^LRO(69,LRODT,1,LRSN,2,TST)) Q:TST<1 S X=^(TST,0) I '$P(X,"^",6),'$P(X,"^",7) W !,"Missing ORIFN at test level:LRODT:"_LRODT_" LRSN:"_LRSN_" IFN:"_TST_">>"_X
Q
CK ;Rebuild C & D -xref in 69
N ODT,SN,X
S ODT=0
F S ODT=$O(^LRO(69,ODT)) Q:ODT<1 S SN=0 F S SN=$O(^LRO(69,ODT,1,SN)) Q:SN<1 I $D(^(SN,0)) S X=^(0) D
. I +X,'$D(^LRO(69,"D",+X,ODT,SN)) S ^LRO(69,"D",+X,ODT,SN)=""
. I '$D(^LRO(69,ODT,1,SN,.1)) Q
. S X=+^LRO(69,ODT,1,SN,.1) I 'X Q
. I '$D(^LRO(69,"C",X,ODT,SN)) S ^LRO(69,"C",X,ODT,SN)=""
Q
COUNT ;Count orders in file 69
N ORD,ODT,SN,X,CT1,CT2,CT3,CT4,X3
S (CT1,CT2,CT3,CT4,ORD)=0
F S ORD=$O(^LRO(69,"C",ORD)) Q:ORD<1 S ODT=0 F S ODT=$O(^LRO(69,"C",ORD,ODT)) Q:ODT<1 S SN=0 F S SN=$O(^LRO(69,"C",ORD,ODT,SN)) Q:SN<1 D
. S CT1=CT1+1
. I $D(^LRO(69,ODT,1,SN)) S CT2=CT2+1 D
.. S TST=0 F S TST=$O(^LRO(69,ODT,1,SN,2,TST)) Q:TST<1 I $D(^(TST,0)) S CT3=CT3+1 I $P(^(0),"^",7),$D(^OR(100,+$P(^(0),"^",7),3)) S X3=$P(^(3),"^",3) I X3'=1,X3'=2,X3'=14 S CT4=CT4+1
W !!,"Valid Specimen Nodes: "_CT2
W !,"Total Specimen Count: "_CT1
W !,"Total Tests: "_CT3
W !,"Tests to Convert: "_CT4
Q
BULL(X,XMSUB) ;Send bulletin
;X()=Array of text to be in bulletin
;XMSUB=Subject of bulletin
S XMY(DUZ)="",XMDUZ=.5,XMTEXT="X("
D ^XMD
Q
TEST(ODT,SN) ;Test HL7 message build without calling
Q:'$L($T(MSG^XQOR))
N MSG,CHMSG,BBMSG,APMSG,LRORD,LRODT,LRSN,LRNIFN,LRTMPO,X,CONTROL
K ^TMP("LRAP",$J),^TMP("LRCH",$J),^TMP("LRBB",$J)
S CONTROL="TEST"
D ORD1^LR7OB1(ODT,SN)
I '$D(LRTMPO("LRIFN")) W !!,"NO LRTMPO(""LRIFN"",LRNIFN) BUILT." D EN1^LR7OB0(ODT,SN,CONTROL) Q
S LRNIFN=0 F S LRNIFN=$O(LRTMPO("LRIFN",LRNIFN)) Q:LRNIFN<1 S X=LRTMPO("LRIFN",LRNIFN) D
. I CONTROL="ZC",$P(X,"^",7) S X=$P($G(^OR(100,+$P(X,"^",7),3)),"^",3) I X=1!(X=2)!(X=14) Q
. D EN1^LR7OB0(ODT,SN,CONTROL)
D DISP
Q
DISP ;Display HL7 message
F I="LRAP","LRBB","LRCH" I $D(^TMP(I,$J)) S J=0 F S J=$O(^TMP(I,$J,J)) Q:J<1 W !,^(J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OC0 4626 printed Nov 22, 2024@17:15 Page 2
LR7OC0 ;slc/dcm - Convert orders from old to new format ;8/11/97
+1 ;;5.2;LAB SERVICE;**121,187**;Sep 27, 1994
+2 ;
EN ;For a good time, enter here. Lab order conversion with KIDS.
+1 ;OE/RR 2.5 Check
IF $$VER^LR7OU1<3
QUIT
+2 SET ZTDTH=$HOROLOG
SET ZTIO=""
SET ZTRTN="EN1^LR7OC0"
DO ^%ZTLOAD
+3 QUIT
EN1 ;Convert orders without KIDS
+1 ;OE/RR 2.5 Check
IF $$VER^LR7OU1<3
QUIT
+2 if $GET(^ORD(100.99,1,"CONV"))
QUIT
+3 NEW LRORD,LRODT,LRSN,TST,LR1,X,SUBHEAD
+4 SET LRORD=$SELECT($GET(^LRO(69,"LRORD CONV",0)):+^(0),1:0)
if 'LRORD
DO CK
+5 FOR
SET LRORD=$ORDER(^LRO(69,"C",LRORD))
if LRORD<1
QUIT
LOCK +^LRCNVRT(LRORD):9999
Begin DoDot:1
+6 SET LRODT=0
FOR
SET LRODT=$ORDER(^LRO(69,"C",LRORD,LRODT))
if LRODT<1
QUIT
SET LRSN=0
FOR
SET LRSN=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSN))
if LRSN<1
QUIT
IF $DATA(^LRO(69,LRODT,1,LRSN,0))
IF '$PIECE(^(0),"^",11)
Begin DoDot:2
+7 DO NEW1^LR7OB0(LRODT,LRSN,"ZC")
+8 SET $PIECE(^LRO(69,LRODT,1,LRSN,0),"^",11)=1.69
End DoDot:2
+9 SET ^LRO(69,"LRORD CONV",0)=LRORD
End DoDot:1
LOCK -^LRCNVRT(LRORD)
+10 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+11 KILL ^LRO(69,"LRORD CONV",0)
+12 SET X(1)="Conversion of lab orders for patch LR*5.2*121 completed: "_Y
+13 SET X(2)="Task #"_$GET(ZTSK)
+14 DO BULL(.X,"Lab Conversion")
+15 IF $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
+16 QUIT
CHK ;Check that all lab orders were converted.
+1 NEW LRORD,LRODT,LRSN,TST,LINK,X0
+2 SET LRORD=0
+3 FOR
SET LRORD=$ORDER(^LRO(69,"C",LRORD))
if LRORD<1
QUIT
Begin DoDot:1
+4 SET LRODT=0
FOR
SET LRODT=$ORDER(^LRO(69,"C",LRORD,LRODT))
if LRODT<1
QUIT
SET LRSN=0
FOR
SET LRSN=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSN))
if LRSN<1
QUIT
IF $DATA(^LRO(69,LRODT,1,LRSN,0))
SET X0=^(0)
IF $DATA(^LR(+X0,0))
IF $PIECE(^(0),"^",2)=2
Begin DoDot:2
+5 SET TST=0
FOR
SET TST=$ORDER(^LRO(69,LRODT,1,LRSN,2,TST))
if TST<1
QUIT
SET T0=^(TST,0)
IF $PIECE(T0,"^",7)
IF '$PIECE(T0,"^",11)
IF '$PIECE(T0,"^",14)
Begin DoDot:3
+6 ;I '$P(X0,"^",6),$P(T0,"^",7),$D(^OR(100,$P(T0,"^",7),0)),$P(^(0),"^",4) S X=$P(^(0),"^",4),$P(^LRO(69,LRODT,1,LRSN,0),"^",6)=X,$P(X0,"^",6)=X
+7 IF $PIECE(T0,"^",7)
IF $DATA(^OR(100,$PIECE(T0,"^",7),0))
IF $GET(^(4))["^"
Begin DoDot:4
+8 SET X=$PIECE($GET(^OR(100,$PIECE(T0,"^",7),3)),"^",3)
IF X=""!(X=1)!(X=2)!(X=14)
QUIT
+9 WRITE !,"NOT CNVRTD-ODT:"_LRODT_" SN:"_LRSN_" ORIFN:"_$PIECE(T0,"^",7)_$SELECT('$PIECE(X0,"^",6):" No Provider",1:"")
SET ORX4=^(4)
SET ORIFN=$PIECE(T0,"^",7)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
CK1 ;Check please (more validity checking). Find bad/missing ptrs to OE/RR 3.0
+1 NEW LRORD,LRODT,LRSN,TST,ORIFN
+2 SET LRORD=0
+3 FOR
SET LRORD=$ORDER(^LRO(69,"C",LRORD))
if LRORD<1
QUIT
Begin DoDot:1
+4 SET LRODT=0
FOR
SET LRODT=$ORDER(^LRO(69,"C",LRORD,LRODT))
if LRODT<1
QUIT
SET LRSN=0
FOR
SET LRSN=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSN))
if LRSN<1
QUIT
IF $DATA(^LRO(69,LRODT,1,LRSN,0))
SET X=^(0)
SET ORIFN=$PIECE(X,"^",11)
IF $DATA(^LR(+X,0))
IF $PIECE(^(0),"^",2)=2
Begin DoDot:2
+5 IF '$LENGTH(ORIFN)
IF $ORDER(^LRO(69,LRODT,1,LRSN,2,0))
WRITE !,"Missing ptr at LRSN level to 100:LRODT:"_LRODT_" LRSN:"_LRSN
QUIT
+6 IF ORIFN
IF ORIFN'=1.69
Begin DoDot:3
+7 IF '$DATA(^OR(100,ORIFN,0))
WRITE !,"Bad ptr to 100:"_X_" LRODT:"_LRODT_" LRSN:"_LRSN
+8 SET TST=0
FOR
SET TST=$ORDER(^LRO(69,LRODT,1,LRSN,2,TST))
if TST<1
QUIT
SET X=^(TST,0)
IF '$PIECE(X,"^",6)
IF '$PIECE(X,"^",7)
WRITE !,"Missing ORIFN at test level:LRODT:"_LRODT_" LRSN:"_LRSN_" IFN:"_TST_">>"_X
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
CK ;Rebuild C & D -xref in 69
+1 NEW ODT,SN,X
+2 SET ODT=0
+3 FOR
SET ODT=$ORDER(^LRO(69,ODT))
if ODT<1
QUIT
SET SN=0
FOR
SET SN=$ORDER(^LRO(69,ODT,1,SN))
if SN<1
QUIT
IF $DATA(^(SN,0))
SET X=^(0)
Begin DoDot:1
+4 IF +X
IF '$DATA(^LRO(69,"D",+X,ODT,SN))
SET ^LRO(69,"D",+X,ODT,SN)=""
+5 IF '$DATA(^LRO(69,ODT,1,SN,.1))
QUIT
+6 SET X=+^LRO(69,ODT,1,SN,.1)
IF 'X
QUIT
+7 IF '$DATA(^LRO(69,"C",X,ODT,SN))
SET ^LRO(69,"C",X,ODT,SN)=""
End DoDot:1
+8 QUIT
COUNT ;Count orders in file 69
+1 NEW ORD,ODT,SN,X,CT1,CT2,CT3,CT4,X3
+2 SET (CT1,CT2,CT3,CT4,ORD)=0
+3 FOR
SET ORD=$ORDER(^LRO(69,"C",ORD))
if ORD<1
QUIT
SET ODT=0
FOR
SET ODT=$ORDER(^LRO(69,"C",ORD,ODT))
if ODT<1
QUIT
SET SN=0
FOR
SET SN=$ORDER(^LRO(69,"C",ORD,ODT,SN))
if SN<1
QUIT
Begin DoDot:1
+4 SET CT1=CT1+1
+5 IF $DATA(^LRO(69,ODT,1,SN))
SET CT2=CT2+1
Begin DoDot:2
+6 SET TST=0
FOR
SET TST=$ORDER(^LRO(69,ODT,1,SN,2,TST))
if TST<1
QUIT
IF $DATA(^(TST,0))
SET CT3=CT3+1
IF $PIECE(^(0),"^",7)
IF $DATA(^OR(100,+$PIECE(^(0),"^",7),3))
SET X3=$PIECE(^(3),"^",3)
IF X3'=1
IF X3'=2
IF X3'=14
SET CT4=CT4+1
End DoDot:2
End DoDot:1
+7 WRITE !!,"Valid Specimen Nodes: "_CT2
+8 WRITE !,"Total Specimen Count: "_CT1
+9 WRITE !,"Total Tests: "_CT3
+10 WRITE !,"Tests to Convert: "_CT4
+11 QUIT
BULL(X,XMSUB) ;Send bulletin
+1 ;X()=Array of text to be in bulletin
+2 ;XMSUB=Subject of bulletin
+3 SET XMY(DUZ)=""
SET XMDUZ=.5
SET XMTEXT="X("
+4 DO ^XMD
+5 QUIT
TEST(ODT,SN) ;Test HL7 message build without calling
+1 if '$LENGTH($TEXT(MSG^XQOR))
QUIT
+2 NEW MSG,CHMSG,BBMSG,APMSG,LRORD,LRODT,LRSN,LRNIFN,LRTMPO,X,CONTROL
+3 KILL ^TMP("LRAP",$JOB),^TMP("LRCH",$JOB),^TMP("LRBB",$JOB)
+4 SET CONTROL="TEST"
+5 DO ORD1^LR7OB1(ODT,SN)
+6 IF '$DATA(LRTMPO("LRIFN"))
WRITE !!,"NO LRTMPO(""LRIFN"",LRNIFN) BUILT."
DO EN1^LR7OB0(ODT,SN,CONTROL)
QUIT
+7 SET LRNIFN=0
FOR
SET LRNIFN=$ORDER(LRTMPO("LRIFN",LRNIFN))
if LRNIFN<1
QUIT
SET X=LRTMPO("LRIFN",LRNIFN)
Begin DoDot:1
+8 IF CONTROL="ZC"
IF $PIECE(X,"^",7)
SET X=$PIECE($GET(^OR(100,+$PIECE(X,"^",7),3)),"^",3)
IF X=1!(X=2)!(X=14)
QUIT
+9 DO EN1^LR7OB0(ODT,SN,CONTROL)
End DoDot:1
+10 DO DISP
+11 QUIT
DISP ;Display HL7 message
+1 FOR I="LRAP","LRBB","LRCH"
IF $DATA(^TMP(I,$JOB))
SET J=0
FOR
SET J=$ORDER(^TMP(I,$JOB,J))
if J<1
QUIT
WRITE !,^(J)
+2 QUIT
