LR7OB0 ;slc/dcm - Build message, backdoor from Lab ;8/11/97
;;5.2T9;LR;**1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**121,187**;Sep 27, 1994
;
NEW(ORD,CONTROL,NAT) ;Create OE/RR order from Lab order #
;Need ORD
;CONTROL=Order control (SN =new order)
;NAT=Nature of order
Q:'$L($T(MSG^XQOR))
N MSG,CHMSG,BBMSG,APMSG,LRORD,LRODT,LRSN,LRNIFN,LRTMPO
K ^TMP("LRAP",$J),^TMP("LRCH",$J),^TMP("LRBB",$J)
D ORD^LR7OB1(ORD)
I '$D(LRTMPO("LRIFN")) D EN(ORD,CONTROL),CALL Q
S LRNIFN=0 F S LRNIFN=$O(LRTMPO("LRIFN",LRNIFN)) Q:LRNIFN<1 D EN(ORD,CONTROL),CALL
Q
NEW1(ODT,SN,CONTROL,NAT) ;Create OE/RR order from Lab order date & LRSN
Q:'$L($T(MSG^XQOR))
N MSG,CHMSG,BBMSG,APMSG,LRORD,LRODT,LRSN,LRNIFN,LRTMPO,X
K ^TMP("LRAP",$J),^TMP("LRCH",$J),^TMP("LRBB",$J)
D ORD1^LR7OB1(ODT,SN)
I '$D(LRTMPO("LRIFN")) D EN1(ODT,SN,CONTROL),CALL 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(ODT,SN,CONTROL),CALL
Q
FIRST S LOC="",ROOM=""
;I $P(LRDPF,"^",2)="DPT(" D INP^VADPT I VAIN(1) S ROOM=VAIN(5),LOC=$S($G(CONTROL)="ZC":+$P(^TMP("LRX",$J,69),"^",7),1:+$G(^DIC(42,+VAIN(4),44)))
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
I $P(LRDPF,"^",2)="DPT(" D @$S($$ISPIMS^BLRUTIL:"INP^VADPT",1:"INP^BLRDPT") I VAIN(1) S ROOM=VAIN(5),LOC=$S($G(CONTROL)="ZC":+$P(^TMP("LRX",$J,69),"^",7),1:+$G(^DIC(42,+VAIN(4),44)))
;----- END IHS MODIFICATIONS
S MSG(1)=$$MSH^LR7OU0("ORM")
S MSG(2)=$$PID^LR7OU0(LRDPF)
S MSG(3)=$$PV1^LR7OU0(LOC,$G(ROOM),"")
S STDT=$$HL7DT^LR7OU0($P(^TMP("LRX",$J,69),"^",2)) ;Obs Start D/T
S X1=CONTROL ;Order Control
S X2=$P(^TMP("LRX",$J,69),"^")_";"_ODT_";"_SN ;Lab #
S X=$G(LRSTATI),X3=$S(X=1:"CA",X=2:"CM",X=6:"SC",1:"IP") ;Status (DFLT=Pend)
S X4="^^^"_STDT_"^"_$$HL7DT^LR7OU0($P(^TMP("LRX",$J,69),"^",9)) ;Quantity/Timing
S X5=$$HL7DT^LR7OU0($P(^TMP("LRX",$J,69),"^",5)) ;Date ordered/entered
S X6=$P(^TMP("LRX",$J,69),"^",6) ;Provider
S X7=STDT ;Order Effective D/T
S X8=$G(NAT) ;Reason
S X9=$S($G(LRNIFN):$S($D(LRTMPO("LRIFN",LRNIFN)):$P(LRTMPO("LRIFN",LRNIFN),"^",7),1:$P(^TMP("LRX",$J,69),"^",11)),1:$P(^TMP("LRX",$J,69),"^",11)) ;OE/RR #
S X10=$P(^TMP("LRX",$J,69),"^",12)
I $D(LINK)#2,$E(LINK)="~" S X9=LINK ;Set to multiple orders if doing conversion
S MSG="MSG",(CTR,ORCMSG)=4 D ORC^LR7OU01(CTR) S MSG=""
Q
EN(ORD,CONTROL,NAT) ;Build msg based on order #
;ORD=Lab order #
;CONTROL=Order control
N I,J,D0,DR,DA,DIC,DIE,CAT,ROOM,LOC,VAIN,VAERR,STDT,X,CTR,II,IFN,IFN1,IFN2,Z,Z1,LOC,X1,X2,X3,X4,X5,X6,X7,X8,X9,X10,Y10,Y,COBR,COBX,DFN,LRDPF,LRDFN,LRFIRST,SEX,ORCMSG,OBRMSG,MSG,CHMSG,BBMSG,APMSG,ODT,SN
S ODT=0,LRFIRST=1,MSG=""
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 69^LR7OB3
Q
EN1(ODT,SN,CONTROL,NAT) ;Build msg based on date and LRSN
;See doc under EN.
;SN=Specimen # in ^LRO(69,ODT,SN,
N I,J,D0,DR,DA,DIC,DIE,CAT,ROOM,LOC,VAIN,VAERR,STDT,X,CTR,IFN,IFN1,IFN2,Z,Z1,LOC,X1,X2,X3,X4,X5,X6,X7,X8,X9,X10,Y10,Y,COBR,COBX,DFN,LRDPF,LRDFN,LRFIRST,SEX,ORCMSG,OBRMSG,MSG,CHMSG,BBMSG,APMSG
K ^TMP("LRX",$J)
S LRFIRST=1,MSG="" D 69^LR7OB3
Q
EN2(AC,ACDT,ACN,CONTROL,CH,BB,AP,NAT) ;Build msg based on Accession area,Acc dt,#
;AC=Accession area
;ACDT=Accession Date
;ACN=Accession #
;CONTROL=Order control
;Y=Output array to pass message in
N I,J,D0,DR,DA,DIC,DIE,CAT,ROOM,LOC,VAIN,VAERR,STDT,X,CTR,IFN,IFN1,IFN2,Z,Z1,LOC,X1,X2,X3,X4,X5,X6,X7,X8,X9,X10,Y10,COBR,COBX,DFN,LRDPF,LRDFN,LRFIRST,SEX,ORCMSG,OBRMSG,XMSG,CHMSG,BBMSG,APMSG,BYPASS
K ^TMP("LRX",$J)
S SS=$P($G(^LRO(68,+$G(AC),0)),"^",2),MSG="^TMP(""LR"_$S("CYEMSPAU"[SS:"AP",SS="BB":"BB",SS="MI":"CH",1:"CH")_""",$J)"
S (BYPASS,LRFIRST)=1 D A68^LR7OB68(ACDT,AC,ACN)
Q:'$D(^TMP("LRX",$J,69)) Q:'$D(ODT) Q:'$D(SN)
D FIRST,SNEAK^LR7OB3 K Y M @MSG=MSG
K ^TMP("LRX",$J)
Q
EN3(LABPAT,SS,INVDT,CONTROL,Y) ;Build msg from 63
;LABPAT=LRDFN (Lab patient ptr)
;SS=Lab Subscript (AU,BB,CH,CY,EM,MI,SP)
;INVDT=Inverse date/time
;CONTROL=Order control
;Y=Output array to pass message in
N I,J,D0,DR,DA,DIC,DIE,CAT,ROOM,LOC,VAIN,VAERR,STDT,X,CTR,IFN,IFN1,IFN2,Z,Z1,LOC,X1,X2,X3,X4,X5,X6,X7,X8,X9,X10,Y10,COBR,COBX,DFN,LRDPF,LRDFN,LRFIRST,SEX,ORCMSG,OBRMSG,XMSG,CHMSG,BBMSG,APMSG
K ^TMP("LRX",$J)
Q:'$G(INVDT) S:'$D(CONTROL) CONTROL="RE"
S MSG="XMSG"
S BYPASS=1 D EN^LR7OB630(LABPAT,SS,INVDT)
Q:'$D(^TMP("LRX",$J,69)) Q:'$D(ODT) Q:'$D(SN)
D FIRST,SNEAK^LR7OB3 K Y M Y=XMSG
K ^TMP("LRX",$J),BYPASS
Q
ALL(RECEIVE) ;Build HL7 message for all patients in file 63
;RECEIVE=Routine entry point to receive message array for each LRIDT
N LRDFN
S LRDFN=0 S:'$D(RECEIVE) RECEIVE=""
F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D PAT(LRDFN,RECEIVE)
Q
PAT(LRDFN,RECEIVE) ;Get data for single patient from file 63
;LRDFN=Lab Patient id
;RECEIVE=Routine entry point to receive message array for each LRIDT
N SS,LRIDT
S SS="A" F S SS=$O(^LR(LRDFN,SS)) Q:SS="" D
. I SS="AU" D EN3(LRDFN,SS,"","SN",.Y) D REC Q
. I SS'="AU" S LRIDT=0 F S LRIDT=$O(^LR(LRDFN,SS,LRIDT)) Q:LRIDT<1 D EN3(LRDFN,SS,LRIDT,"RR",.Y),REC
Q
REC ;Send to receiving routine
I $L($G(RECEIVE)),RECEIVE["^" S X=$P(RECEIVE,"^",2) X ^%ZOSF("TEST") I $T D @RECEIVE
Q
CALL ;Make call to OE/RR and cleanup
D CALL^LR7OB1(CONTROL)
K ^TMP("LRAP",$J),^TMP("LRCH",$J),^TMP("LRBB",$J)
Q
LR7OB0 ;slc/dcm - Build message, backdoor from Lab ;8/11/97
+1 ;;5.2T9;LR;**1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**121,187**;Sep 27, 1994
+3 ;
NEW(ORD,CONTROL,NAT) ;Create OE/RR order from Lab order #
+1 ;Need ORD
+2 ;CONTROL=Order control (SN =new order)
+3 ;NAT=Nature of order
+4 IF '$LENGTH($TEXT(MSG^XQOR))
QUIT
+5 NEW MSG,CHMSG,BBMSG,APMSG,LRORD,LRODT,LRSN,LRNIFN,LRTMPO
+6 KILL ^TMP("LRAP",$JOB),^TMP("LRCH",$JOB),^TMP("LRBB",$JOB)
+7 DO ORD^LR7OB1(ORD)
+8 IF '$DATA(LRTMPO("LRIFN"))
DO EN(ORD,CONTROL)
DO CALL
QUIT
+9 SET LRNIFN=0
FOR
SET LRNIFN=$ORDER(LRTMPO("LRIFN",LRNIFN))
IF LRNIFN<1
QUIT
DO EN(ORD,CONTROL)
DO CALL
+10 QUIT
NEW1(ODT,SN,CONTROL,NAT) ;Create OE/RR order from Lab order date & LRSN
+1 IF '$LENGTH($TEXT(MSG^XQOR))
QUIT
+2 NEW MSG,CHMSG,BBMSG,APMSG,LRORD,LRODT,LRSN,LRNIFN,LRTMPO,X
+3 KILL ^TMP("LRAP",$JOB),^TMP("LRCH",$JOB),^TMP("LRBB",$JOB)
+4 DO ORD1^LR7OB1(ODT,SN)
+5 IF '$DATA(LRTMPO("LRIFN"))
DO EN1(ODT,SN,CONTROL)
DO CALL
QUIT
+6 SET LRNIFN=0
FOR
SET LRNIFN=$ORDER(LRTMPO("LRIFN",LRNIFN))
IF LRNIFN<1
QUIT
SET X=LRTMPO("LRIFN",LRNIFN)
Begin DoDot:1
+7 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
+8 DO EN1(ODT,SN,CONTROL)
DO CALL
End DoDot:1
+9 QUIT
FIRST SET LOC=""
SET ROOM=""
+1 ;I $P(LRDPF,"^",2)="DPT(" D INP^VADPT I VAIN(1) S ROOM=VAIN(5),LOC=$S($G(CONTROL)="ZC":+$P(^TMP("LRX",$J,69),"^",7),1:+$G(^DIC(42,+VAIN(4),44)))
+2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+3 IF $PIECE(LRDPF,"^",2)="DPT("
DO @$SELECT($$ISPIMS^BLRUTIL:"INP^VADPT",1:"INP^BLRDPT")
IF VAIN(1)
SET ROOM=VAIN(5)
SET LOC=$SELECT($GET(CONTROL)="ZC":+$PIECE(^TMP("LRX",$JOB,69),"^",7),1:+$GET(^DIC(42,+VAIN(4),44)))
+4 ;----- END IHS MODIFICATIONS
+5 SET MSG(1)=$$MSH^LR7OU0("ORM")
+6 SET MSG(2)=$$PID^LR7OU0(LRDPF)
+7 SET MSG(3)=$$PV1^LR7OU0(LOC,$GET(ROOM),"")
+8 ;Obs Start D/T
SET STDT=$$HL7DT^LR7OU0($PIECE(^TMP("LRX",$JOB,69),"^",2))
+9 ;Order Control
SET X1=CONTROL
+10 ;Lab #
SET X2=$PIECE(^TMP("LRX",$JOB,69),"^")_";"_ODT_";"_SN
+11 ;Status (DFLT=Pend)
SET X=$GET(LRSTATI)
SET X3=$SELECT(X=1:"CA",X=2:"CM",X=6:"SC",1:"IP")
+12 ;Quantity/Timing
SET X4="^^^"_STDT_"^"_$$HL7DT^LR7OU0($PIECE(^TMP("LRX",$JOB,69),"^",9))
+13 ;Date ordered/entered
SET X5=$$HL7DT^LR7OU0($PIECE(^TMP("LRX",$JOB,69),"^",5))
+14 ;Provider
SET X6=$PIECE(^TMP("LRX",$JOB,69),"^",6)
+15 ;Order Effective D/T
SET X7=STDT
+16 ;Reason
SET X8=$GET(NAT)
+17 ;OE/RR #
SET X9=$SELECT($GET(LRNIFN):$SELECT($DATA(LRTMPO("LRIFN",LRNIFN)):$PIECE(LRTMPO("LRIFN",LRNIFN),"^",7),1:$PIECE(^TMP("LRX",$JOB,69),"^",11)),1:$PIECE(^TMP("LRX",$JOB,69),"^",11))
+18 SET X10=$PIECE(^TMP("LRX",$JOB,69),"^",12)
+19 ;Set to multiple orders if doing conversion
IF $DATA(LINK)#2
IF $EXTRACT(LINK)="~"
SET X9=LINK
+20 SET MSG="MSG"
SET (CTR,ORCMSG)=4
DO ORC^LR7OU01(CTR)
SET MSG=""
+21 QUIT
EN(ORD,CONTROL,NAT) ;Build msg based on order #
+1 ;ORD=Lab order #
+2 ;CONTROL=Order control
+3 NEW I,J,D0,DR,DA,DIC,DIE,CAT,ROOM,LOC,VAIN,VAERR,STDT,X,CTR,II,IFN,IFN1,IFN2,Z,Z1,LOC,X1,X2,X3,X4,X5,X6,X7,X8,X9,X10,Y10,Y,COBR,COBX,DFN,LRDPF,LRDFN,LRFIRST,SEX,ORCMSG,OBRMSG,MSG,CHMSG,BBMSG,APMSG,ODT,SN
+4 SET ODT=0
SET LRFIRST=1
SET MSG=""
+5 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
DO 69^LR7OB3
+6 QUIT
EN1(ODT,SN,CONTROL,NAT) ;Build msg based on date and LRSN
+1 ;See doc under EN.
+2 ;SN=Specimen # in ^LRO(69,ODT,SN,
+3 NEW I,J,D0,DR,DA,DIC,DIE,CAT,ROOM,LOC,VAIN,VAERR,STDT,X,CTR,IFN,IFN1,IFN2,Z,Z1,LOC,X1,X2,X3,X4,X5,X6,X7,X8,X9,X10,Y10,Y,COBR,COBX,DFN,LRDPF,LRDFN,LRFIRST,SEX,ORCMSG,OBRMSG,MSG,CHMSG,BBMSG,APMSG
+4 KILL ^TMP("LRX",$JOB)
+5 SET LRFIRST=1
SET MSG=""
DO 69^LR7OB3
+6 QUIT
EN2(AC,ACDT,ACN,CONTROL,CH,BB,AP,NAT) ;Build msg based on Accession area,Acc dt,#
+1 ;AC=Accession area
+2 ;ACDT=Accession Date
+3 ;ACN=Accession #
+4 ;CONTROL=Order control
+5 ;Y=Output array to pass message in
+6 NEW I,J,D0,DR,DA,DIC,DIE,CAT,ROOM,LOC,VAIN,VAERR,STDT,X,CTR,IFN,IFN1,IFN2,Z,Z1,LOC,X1,X2,X3,X4,X5,X6,X7,X8,X9,X10,Y10,COBR,COBX,DFN,LRDPF,LRDFN,LRFIRST,SEX,ORCMSG,OBRMSG,XMSG,CHMSG,BBMSG,APMSG,BYPASS
+7 KILL ^TMP("LRX",$JOB)
+8 SET SS=$PIECE($GET(^LRO(68,+$GET(AC),0)),"^",2)
SET MSG="^TMP(""LR"_$SELECT("CYEMSPAU"[SS:"AP",SS="BB":"BB",SS="MI":"CH",1:"CH")_""",$J)"
+9 SET (BYPASS,LRFIRST)=1
DO A68^LR7OB68(ACDT,AC,ACN)
+10 IF '$DATA(^TMP("LRX",$JOB,69))
QUIT
IF '$DATA(ODT)
QUIT
IF '$DATA(SN)
QUIT
+11 DO FIRST
DO SNEAK^LR7OB3
KILL Y
MERGE @MSG=MSG
+12 KILL ^TMP("LRX",$JOB)
+13 QUIT
EN3(LABPAT,SS,INVDT,CONTROL,Y) ;Build msg from 63
+1 ;LABPAT=LRDFN (Lab patient ptr)
+2 ;SS=Lab Subscript (AU,BB,CH,CY,EM,MI,SP)
+3 ;INVDT=Inverse date/time
+4 ;CONTROL=Order control
+5 ;Y=Output array to pass message in
+6 NEW I,J,D0,DR,DA,DIC,DIE,CAT,ROOM,LOC,VAIN,VAERR,STDT,X,CTR,IFN,IFN1,IFN2,Z,Z1,LOC,X1,X2,X3,X4,X5,X6,X7,X8,X9,X10,Y10,COBR,COBX,DFN,LRDPF,LRDFN,LRFIRST,SEX,ORCMSG,OBRMSG,XMSG,CHMSG,BBMSG,APMSG
+7 KILL ^TMP("LRX",$JOB)
+8 IF '$GET(INVDT)
QUIT
IF '$DATA(CONTROL)
SET CONTROL="RE"
+9 SET MSG="XMSG"
+10 SET BYPASS=1
DO EN^LR7OB630(LABPAT,SS,INVDT)
+11 IF '$DATA(^TMP("LRX",$JOB,69))
QUIT
IF '$DATA(ODT)
QUIT
IF '$DATA(SN)
QUIT
+12 DO FIRST
DO SNEAK^LR7OB3
KILL Y
MERGE Y=XMSG
+13 KILL ^TMP("LRX",$JOB),BYPASS
+14 QUIT
ALL(RECEIVE) ;Build HL7 message for all patients in file 63
+1 ;RECEIVE=Routine entry point to receive message array for each LRIDT
+2 NEW LRDFN
+3 SET LRDFN=0
IF '$DATA(RECEIVE)
SET RECEIVE=""
+4 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
IF LRDFN<1
QUIT
DO PAT(LRDFN,RECEIVE)
+5 QUIT
PAT(LRDFN,RECEIVE) ;Get data for single patient from file 63
+1 ;LRDFN=Lab Patient id
+2 ;RECEIVE=Routine entry point to receive message array for each LRIDT
+3 NEW SS,LRIDT
+4 SET SS="A"
FOR
SET SS=$ORDER(^LR(LRDFN,SS))
IF SS=""
QUIT
Begin DoDot:1
+5 IF SS="AU"
DO EN3(LRDFN,SS,"","SN",.Y)
DO REC
QUIT
+6 IF SS'="AU"
SET LRIDT=0
FOR
SET LRIDT=$ORDER(^LR(LRDFN,SS,LRIDT))
IF LRIDT<1
QUIT
DO EN3(LRDFN,SS,LRIDT,"RR",.Y)
DO REC
End DoDot:1
+7 QUIT
REC ;Send to receiving routine
+1 IF $LENGTH($GET(RECEIVE))
IF RECEIVE["^"
SET X=$PIECE(RECEIVE,"^",2)
XECUTE ^%ZOSF("TEST")
IF $TEST
DO @RECEIVE
+2 QUIT
CALL ;Make call to OE/RR and cleanup
+1 DO CALL^LR7OB1(CONTROL)
+2 KILL ^TMP("LRAP",$JOB),^TMP("LRCH",$JOB),^TMP("LRBB",$JOB)
+3 QUIT
