- LR7OB0 ;slc/dcm - Build message, backdoor from Lab ;8/11/97
- ;;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)))
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OB0 5163 printed Feb 18, 2025@23:30:38 Page 2
- LR7OB0 ;slc/dcm - Build message, backdoor from Lab ;8/11/97
- +1 ;;5.2;LAB SERVICE;**121,187**;Sep 27, 1994
- +2 ;
- 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 IF $PIECE(LRDPF,"^",2)="DPT("
- DO INP^VADPT
- 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)))
- +2 SET MSG(1)=$$MSH^LR7OU0("ORM")
- +3 SET MSG(2)=$$PID^LR7OU0(LRDPF)
- +4 SET MSG(3)=$$PV1^LR7OU0(LOC,$GET(ROOM),"")
- +5 ;Obs Start D/T
- SET STDT=$$HL7DT^LR7OU0($PIECE(^TMP("LRX",$JOB,69),"^",2))
- +6 ;Order Control
- SET X1=CONTROL
- +7 ;Lab #
- SET X2=$PIECE(^TMP("LRX",$JOB,69),"^")_";"_ODT_";"_SN
- +8 ;Status (DFLT=Pend)
- SET X=$GET(LRSTATI)
- SET X3=$SELECT(X=1:"CA",X=2:"CM",X=6:"SC",1:"IP")
- +9 ;Quantity/Timing
- SET X4="^^^"_STDT_"^"_$$HL7DT^LR7OU0($PIECE(^TMP("LRX",$JOB,69),"^",9))
- +10 ;Date ordered/entered
- SET X5=$$HL7DT^LR7OU0($PIECE(^TMP("LRX",$JOB,69),"^",5))
- +11 ;Provider
- SET X6=$PIECE(^TMP("LRX",$JOB,69),"^",6)
- +12 ;Order Effective D/T
- SET X7=STDT
- +13 ;Reason
- SET X8=$GET(NAT)
- +14 ;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))
- +15 SET X10=$PIECE(^TMP("LRX",$JOB,69),"^",12)
- +16 ;Set to multiple orders if doing conversion
- IF $DATA(LINK)#2
- IF $EXTRACT(LINK)="~"
- SET X9=LINK
- +17 SET MSG="MSG"
- SET (CTR,ORCMSG)=4
- DO ORC^LR7OU01(CTR)
- SET MSG=""
- +18 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