ORMBLDLR ; SLC/MKB - Build outgoing Lab ORM msgs ;Jan 27, 2021@09:24:22
;;3.0;ORDER ENTRY/RESULTS REPORTING;**97,190,195,539**;Dec 17, 1997;Build 41
;
; This routine uses the following ICRs:
; #7215 - LOOK^LR7OAPKM
;
HL7DATE(DATE) ; -- FM -> HL7 format
Q $$FMTHL7^XLFDT(DATE) ;**97
;
PTR(NAME) ; -- Returns ptr value of prompt in Dialog file
Q $O(^ORD(101.41,"AB",$E(NAME,1,63),0))
;
AP ; -- new Lab AP order
; fall through to CH - no difference at this time
CH ; -- new Lab CH order
N IP,OI,START,STOP,URG,CMMT,INST,I,J,X
S START=$P($G(^OR(100,IFN,0)),U,8),STOP=$P($G(^(0)),U,9)
S OI=$$PTR("OR GTX ORDERABLE ITEM"),URG=$$PTR("OR GTX LAB URGENCY")
S CMMT=$$PTR("OR GTX WORD PROCESSING 1")
S IP="" ;$S($D(^OR(100,<ISOLATION ORDER FOR DFN>)):1,1:0)
S $P(ORMSG(4),"|",8)="^^^"_$$HL7DATE(START)_U_$$HL7DATE(STOP)
S I=4,INST=0 F S INST=$O(ORDIALOG(OI,INST)) Q:INST'>0 D
. S X=+$G(ORDIALOG(URG,INST)),X=$P($G(^LAB(62.05,X,0)),U,4)_";"_X
. S I=I+1,ORMSG(I)="OBR||||"_$$USID^ORMBLD(ORDIALOG(OI,INST))_"|||||||"_$$COLLTYPE_"|"_IP_"|||"_$$SPEC_"||||||||||||^^^^^"_X
. N AP1 S AP1=$$APSUB(ORIFN) I $P(AP1,"|")?1(1"SP",1"CY",1"EM") D
. . N LST S I=I+1,ORMSG(I)="AP1|"_ORIFN_"||"_$G(AP1)
. S J=$O(^TMP("ORWORD",$J,CMMT,INST,0)) Q:'J ; no comments for test
. S I=I+1,ORMSG(I)="NTE|"_INST_"|P|"_^TMP("ORWORD",$J,CMMT,INST,J,0)
. S L=0 F S J=$O(^TMP("ORWORD",$J,CMMT,INST,J)) Q:J'>0 S L=L+1,ORMSG(I,L)=^(J,0)
; Add DG1 & ZCL segment(s) for Billing Aware
D DG1^ORWDBA3($G(IFN),"I",I)
Q
;
BB ; -- new Lab BB order
N START,QUAN,WP,I,J
S QUAN=+$G(ORDIALOG($$PTR("OR GTX QUANTITY"),1))
S START=$P(^OR(100,IFN,0),U,8),WP=$$PTR("OR GTX WORD PROCESSING 1")
S $P(ORMSG(4),"|",8)=QUAN_"^^^"_$$HL7DATE(START)
S ORMSG(5)="OBR||||"_$G(ORDIALOG($$PTR("OR GTX ORDERABLE ITEM"),1))
S I=$O(^TMP("ORWORD",$J,WP,1,0)) Q:'I
S ORMSG(6)="NTE|1|P|"_$G(^TMP("ORWORD",$J,WP,1,I,0)),J=0
F S I=$O(^TMP("ORWORD",$J,WP,1,I)) Q:I'>0 S J=J+1,ORMSG(6,J)=$G(^(I,0))
Q
;
COLLTYPE() ; -- Returns collection type for current INST
N TYPE,X
S TYPE=$G(ORDIALOG($$PTR("OR GTX COLLECTION TYPE"),INST))
S X=$S(TYPE="LC":"L",TYPE="WC":"O",TYPE="SP":1,TYPE="I":2,1:"")
Q X
;
SPEC() ; -- Returns specimen/sample string for current INST
N SAMP,SPEC,X,X0
S SPEC=+$G(ORDIALOG($$PTR("OR GTX SPECIMEN"),INST))
S X0=$G(^LAB(61,SPEC,0)),X=$P(X0,U,2)_";"_$P(X0,U)_";SNM"
S SAMP=+$G(ORDIALOG($$PTR("OR GTX COLLECTION SAMPLE"),INST))
S X=X_";"_SAMP_";"_$P($G(^LAB(62,+SAMP,0)),U)_";99LRS^^^"_SPEC_";"_$P(X0,U)_";99LRX"
Q X
;
XO ; -- Send XO message to Lab
N OR0,DG,ORMSG,ORNEW,OI,URG,I,CNT,INST,ORDIALOG,TEST,CMMT,J,L,OROLD
S OR0=$G(^OR(100,+IFN,0)),DG=$P($G(^ORD(100.98,+$P(OR0,U,11),0)),U,3)
S DG="LR"_$S(DG="AP":"AP",DG="BB":"BB",1:"CH"),ORDIALOG=+$P(OR0,U,5)
S OROLD=+$P(^OR(100,IFN,3),U,5),$P(ORMSG(4),"|",4)=$G(^OR(100,+OROLD,4))_U_DG
S OI=$$PTR("OR GTX ORDERABLE ITEM"),URG=$$PTR("OR GTX URGENCY")
S CMMT=$$PTR("OR GTX WORD PROCESSING 1"),CNT=3
S I=0 F S I=$O(^OR(100,+IFN,4.5,I)) Q:I'>0 I $P($G(^(I,0)),U,2)=OI S TEST=$G(^(1)),ORNEW(TEST)=^(0) ; new set of tests
S I=0 F S I=$O(^OR(100,OROLD,4.5,I)) Q:I'>0 I $P($G(^(I,0)),U,2)=OI S TEST=$G(^(1)),OROLD(TEST)=^(0) ; orig set of tests
XO1 D GETDLG1^ORCD(ORDIALOG),GETORDER^ORCD(+IFN)
S I=0 F S I=$O(ORNEW(I)) Q:I'>0 I '$D(OROLD(I)) D
. S CNT=CNT+1,TEST=I,INST=$P(ORNEW(I),U,3)
. S ORMSG(CNT)="OBR|"_(CNT-3)_"|||"_$$USID^ORMBLD(TEST)_"|||||||A||||"_$$SPEC_"||||||||||||^^^^^"_$P($G(^ORD(101.42,+$G(ORDIALOG(URG,INST)),0)),U,2)
. S J=$O(^TMP("ORWORD",$J,CMMT,INST,0)) Q:'J ; no comments for test
. S CNT=CNT+1,ORMSG(CNT)="NTE|"_INST_"|L|"_^TMP("ORWORD",$J,CMMT,INST,J,0)
. S L=0 F S J=$O(^TMP("ORWORD",$J,CMMT,INST,J)) Q:J'>0 S L=L+1,ORMSG(CNT,L)=^(J,0)
S I=ORDIALOG K ORDIALOG S ORDIALOG=I
D GETDLG1^ORCD(ORDIALOG),GETORDER^ORCD(OROLD)
S I=0 F S I=$O(OROLD(I)) Q:I'>0 I '$D(ORNEW(I)) D
. S CNT=CNT+1,TEST=I,INST=$P(OROLD(I),U,3)
. S ORMSG(CNT)="OBR|"_(CNT-3)_"|||"_$$USID^ORMBLD(TEST)_"|||||||3||||"_$$SPEC_"||||||||||||^^^^^"_$P($G(^ORD(101.42,+$G(ORDIALOG(URG,INST)),0)),U,2)
. S J=$O(^TMP("ORWORD",$J,CMMT,INST,0)) Q:'J ; no comments for test
. S CNT=CNT+1,ORMSG(CNT)="NTE|"_INST_"|L|"_^TMP("ORWORD",$J,CMMT,INST,J,0)
. S L=0 F S J=$O(^TMP("ORWORD",$J,CMMT,INST,J)) Q:J'>0 S L=L+1,ORMSG(CNT,L)=^(J,0)
D MSG^XQOR("OR EVSEND "_DG,.ORMSG)
Q
APSUB(ORIFN) ;* - determine if Anatomic Path test subscript for AP1 segment and make call to get LR CPRS SCREEN pointer
N ANS,DIERR,ERR,ITEM,NUM,SUB,TESTIEN
S ITEM=$$VALUE^ORX8(+ORIFN,"ORDERABLE",,"I")
S TESTIEN=+$$GET1^DIQ(101.43,ITEM_",",2,"E","ERR")
S SUB=$$GET1^DIQ(60,TESTIEN_",",4,"I","ERR")
D LOOK^LR7OAPKM(TESTIEN,,.ANS)
S NUM=+$O(ANS(0))
I $G(SUB)'?1(1"SP",1"CY",1"EM") Q $G(SUB)
Q $G(SUB)_"|||"_$G(ANS(NUM))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMBLDLR 4845 printed Apr 09, 2024@21:31:43 Page 2
ORMBLDLR ; SLC/MKB - Build outgoing Lab ORM msgs ;Jan 27, 2021@09:24:22
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**97,190,195,539**;Dec 17, 1997;Build 41
+2 ;
+3 ; This routine uses the following ICRs:
+4 ; #7215 - LOOK^LR7OAPKM
+5 ;
HL7DATE(DATE) ; -- FM -> HL7 format
+1 ;**97
QUIT $$FMTHL7^XLFDT(DATE)
+2 ;
PTR(NAME) ; -- Returns ptr value of prompt in Dialog file
+1 QUIT $ORDER(^ORD(101.41,"AB",$EXTRACT(NAME,1,63),0))
+2 ;
AP ; -- new Lab AP order
+1 ; fall through to CH - no difference at this time
CH ; -- new Lab CH order
+1 NEW IP,OI,START,STOP,URG,CMMT,INST,I,J,X
+2 SET START=$PIECE($GET(^OR(100,IFN,0)),U,8)
SET STOP=$PIECE($GET(^(0)),U,9)
+3 SET OI=$$PTR("OR GTX ORDERABLE ITEM")
SET URG=$$PTR("OR GTX LAB URGENCY")
+4 SET CMMT=$$PTR("OR GTX WORD PROCESSING 1")
+5 ;$S($D(^OR(100,<ISOLATION ORDER FOR DFN>)):1,1:0)
SET IP=""
+6 SET $PIECE(ORMSG(4),"|",8)="^^^"_$$HL7DATE(START)_U_$$HL7DATE(STOP)
+7 SET I=4
SET INST=0
FOR
SET INST=$ORDER(ORDIALOG(OI,INST))
if INST'>0
QUIT
Begin DoDot:1
+8 SET X=+$GET(ORDIALOG(URG,INST))
SET X=$PIECE($GET(^LAB(62.05,X,0)),U,4)_";"_X
+9 SET I=I+1
SET ORMSG(I)="OBR||||"_$$USID^ORMBLD(ORDIALOG(OI,INST))_"|||||||"_$$COLLTYPE_"|"_IP_"|||"_$$SPEC_"||||||||||||^^^^^"_X
+10 NEW AP1
SET AP1=$$APSUB(ORIFN)
IF $PIECE(AP1,"|")?1(1"SP",1"CY",1"EM")
Begin DoDot:2
+11 NEW LST
SET I=I+1
SET ORMSG(I)="AP1|"_ORIFN_"||"_$GET(AP1)
End DoDot:2
+12 ; no comments for test
SET J=$ORDER(^TMP("ORWORD",$JOB,CMMT,INST,0))
if 'J
QUIT
+13 SET I=I+1
SET ORMSG(I)="NTE|"_INST_"|P|"_^TMP("ORWORD",$JOB,CMMT,INST,J,0)
+14 SET L=0
FOR
SET J=$ORDER(^TMP("ORWORD",$JOB,CMMT,INST,J))
if J'>0
QUIT
SET L=L+1
SET ORMSG(I,L)=^(J,0)
End DoDot:1
+15 ; Add DG1 & ZCL segment(s) for Billing Aware
+16 DO DG1^ORWDBA3($GET(IFN),"I",I)
+17 QUIT
+18 ;
BB ; -- new Lab BB order
+1 NEW START,QUAN,WP,I,J
+2 SET QUAN=+$GET(ORDIALOG($$PTR("OR GTX QUANTITY"),1))
+3 SET START=$PIECE(^OR(100,IFN,0),U,8)
SET WP=$$PTR("OR GTX WORD PROCESSING 1")
+4 SET $PIECE(ORMSG(4),"|",8)=QUAN_"^^^"_$$HL7DATE(START)
+5 SET ORMSG(5)="OBR||||"_$GET(ORDIALOG($$PTR("OR GTX ORDERABLE ITEM"),1))
+6 SET I=$ORDER(^TMP("ORWORD",$JOB,WP,1,0))
if 'I
QUIT
+7 SET ORMSG(6)="NTE|1|P|"_$GET(^TMP("ORWORD",$JOB,WP,1,I,0))
SET J=0
+8 FOR
SET I=$ORDER(^TMP("ORWORD",$JOB,WP,1,I))
if I'>0
QUIT
SET J=J+1
SET ORMSG(6,J)=$GET(^(I,0))
+9 QUIT
+10 ;
COLLTYPE() ; -- Returns collection type for current INST
+1 NEW TYPE,X
+2 SET TYPE=$GET(ORDIALOG($$PTR("OR GTX COLLECTION TYPE"),INST))
+3 SET X=$SELECT(TYPE="LC":"L",TYPE="WC":"O",TYPE="SP":1,TYPE="I":2,1:"")
+4 QUIT X
+5 ;
SPEC() ; -- Returns specimen/sample string for current INST
+1 NEW SAMP,SPEC,X,X0
+2 SET SPEC=+$GET(ORDIALOG($$PTR("OR GTX SPECIMEN"),INST))
+3 SET X0=$GET(^LAB(61,SPEC,0))
SET X=$PIECE(X0,U,2)_";"_$PIECE(X0,U)_";SNM"
+4 SET SAMP=+$GET(ORDIALOG($$PTR("OR GTX COLLECTION SAMPLE"),INST))
+5 SET X=X_";"_SAMP_";"_$PIECE($GET(^LAB(62,+SAMP,0)),U)_";99LRS^^^"_SPEC_";"_$PIECE(X0,U)_";99LRX"
+6 QUIT X
+7 ;
XO ; -- Send XO message to Lab
+1 NEW OR0,DG,ORMSG,ORNEW,OI,URG,I,CNT,INST,ORDIALOG,TEST,CMMT,J,L,OROLD
+2 SET OR0=$GET(^OR(100,+IFN,0))
SET DG=$PIECE($GET(^ORD(100.98,+$PIECE(OR0,U,11),0)),U,3)
+3 SET DG="LR"_$SELECT(DG="AP":"AP",DG="BB":"BB",1:"CH")
SET ORDIALOG=+$PIECE(OR0,U,5)
+4 SET OROLD=+$PIECE(^OR(100,IFN,3),U,5)
SET $PIECE(ORMSG(4),"|",4)=$GET(^OR(100,+OROLD,4))_U_DG
+5 SET OI=$$PTR("OR GTX ORDERABLE ITEM")
SET URG=$$PTR("OR GTX URGENCY")
+6 SET CMMT=$$PTR("OR GTX WORD PROCESSING 1")
SET CNT=3
+7 ; new set of tests
SET I=0
FOR
SET I=$ORDER(^OR(100,+IFN,4.5,I))
if I'>0
QUIT
IF $PIECE($GET(^(I,0)),U,2)=OI
SET TEST=$GET(^(1))
SET ORNEW(TEST)=^(0)
+8 ; orig set of tests
SET I=0
FOR
SET I=$ORDER(^OR(100,OROLD,4.5,I))
if I'>0
QUIT
IF $PIECE($GET(^(I,0)),U,2)=OI
SET TEST=$GET(^(1))
SET OROLD(TEST)=^(0)
XO1 DO GETDLG1^ORCD(ORDIALOG)
DO GETORDER^ORCD(+IFN)
+1 SET I=0
FOR
SET I=$ORDER(ORNEW(I))
if I'>0
QUIT
IF '$DATA(OROLD(I))
Begin DoDot:1
+2 SET CNT=CNT+1
SET TEST=I
SET INST=$PIECE(ORNEW(I),U,3)
+3 SET ORMSG(CNT)="OBR|"_(CNT-3)_"|||"_$$USID^ORMBLD(TEST)_"|||||||A||||"_$$SPEC_"||||||||||||^^^^^"_$P($GET(^ORD(101.42,+$GET(ORDIALOG(URG,INST)),0)),U,2)
+4 ; no comments for test
SET J=$ORDER(^TMP("ORWORD",$JOB,CMMT,INST,0))
if 'J
QUIT
+5 SET CNT=CNT+1
SET ORMSG(CNT)="NTE|"_INST_"|L|"_^TMP("ORWORD",$JOB,CMMT,INST,J,0)
+6 SET L=0
FOR
SET J=$ORDER(^TMP("ORWORD",$JOB,CMMT,INST,J))
if J'>0
QUIT
SET L=L+1
SET ORMSG(CNT,L)=^(J,0)
End DoDot:1
+7 SET I=ORDIALOG
KILL ORDIALOG
SET ORDIALOG=I
+8 DO GETDLG1^ORCD(ORDIALOG)
DO GETORDER^ORCD(OROLD)
+9 SET I=0
FOR
SET I=$ORDER(OROLD(I))
if I'>0
QUIT
IF '$DATA(ORNEW(I))
Begin DoDot:1
+10 SET CNT=CNT+1
SET TEST=I
SET INST=$PIECE(OROLD(I),U,3)
+11 SET ORMSG(CNT)="OBR|"_(CNT-3)_"|||"_$$USID^ORMBLD(TEST)_"|||||||3||||"_$$SPEC_"||||||||||||^^^^^"_$P($GET(^ORD(101.42,+$GET(ORDIALOG(URG,INST)),0)),U,2)
+12 ; no comments for test
SET J=$ORDER(^TMP("ORWORD",$JOB,CMMT,INST,0))
if 'J
QUIT
+13 SET CNT=CNT+1
SET ORMSG(CNT)="NTE|"_INST_"|L|"_^TMP("ORWORD",$JOB,CMMT,INST,J,0)
+14 SET L=0
FOR
SET J=$ORDER(^TMP("ORWORD",$JOB,CMMT,INST,J))
if J'>0
QUIT
SET L=L+1
SET ORMSG(CNT,L)=^(J,0)
End DoDot:1
+15 DO MSG^XQOR("OR EVSEND "_DG,.ORMSG)
+16 QUIT
APSUB(ORIFN) ;* - determine if Anatomic Path test subscript for AP1 segment and make call to get LR CPRS SCREEN pointer
+1 NEW ANS,DIERR,ERR,ITEM,NUM,SUB,TESTIEN
+2 SET ITEM=$$VALUE^ORX8(+ORIFN,"ORDERABLE",,"I")
+3 SET TESTIEN=+$$GET1^DIQ(101.43,ITEM_",",2,"E","ERR")
+4 SET SUB=$$GET1^DIQ(60,TESTIEN_",",4,"I","ERR")
+5 DO LOOK^LR7OAPKM(TESTIEN,,.ANS)
+6 SET NUM=+$ORDER(ANS(0))
+7 IF $GET(SUB)'?1(1"SP",1"CY",1"EM")
QUIT $GET(SUB)
+8 QUIT $GET(SUB)_"|||"_$GET(ANS(NUM))
