- 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 Mar 13, 2025@21:09:16 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
