- LR7OF2 ;SLC/DCM - Process messages from OE/RR ;Mar 18, 2022@16:55
- ;;5.2;LAB SERVICE;**121,187,440,538,557**;Sep 27, 1994;Build 2
- ;
- NEW ;Process New orders from OE/RR
- ;LRXMSG=Message with linking identifiers
- ;LRXORC=Current ORC message value - for communicating back to OE/RR
- D GET(.LRXMSG,LRXORC) Q:LREND
- I '$L(STARTDT) D ACK^LR7OF0("DE",LRXORC,"Start date not passed in message") S LREND=1 Q
- I '$L(LRDUZ) D ACK^LR7OF0("DE",LRXORC,"Entered By person not passed in message") S LREND=1 Q
- I '$L(PROV) D ACK^LR7OF0("DE",LRXORC,"Provider not passed in message") S LREND=1 Q
- Q
- CANC ;Process Canceled orders from OE/RR
- N TST,X,LRODT,LRSN,LRORD,LRORIFN,STARTDT,LRDUZ,PROV,REASON,QUANT
- D GET(.LRXORC,LRXORC) Q:LREND
- I 'LRVERZ 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 D Q
- . S X=$P($P(LRXMSG,"|",5),"^",4) I X S TST=$O(^LRO(69,LRODT,1,LRSN,2,"B",X,0)) I TST D DOIT(LRODT,LRSN,TST,LRXORC,LRDUZ,REASON) Q:LREND
- I LRVERZ,$D(^LRO(69,LRODT,1,LRSN,0)) D Q:LREND
- . S X=$P($P(LRXMSG,"|",5),"^",4),TST=""
- . I X S TST=$O(^LRO(69,LRODT,1,LRSN,2,"B",X,0))
- . I TST D DOIT(LRODT,LRSN,TST,LRXORC,LRDUZ,REASON) D
- . . ;LR*5.2*557: If line below is invoked for VBECS-originated
- . . ; cancellations, VistA status will not update correctly.
- . . I $G(ORNMSP)'="VBEC" D CHKCOMB(LRODT,LRSN,TST,LRXORC,LRDUZ,REASON)
- D ACK^LR7OF0("CR",LRXORC)
- Q
- XO ;Process order changes from OE/RR
- D GET(.LRXMSG,LRXORC) Q:LREND
- D ACK^LR7OF0("XR",LRXORC)
- Q
- DOIT(LRODT,LRSN,TST,LRXORC,LRDUZ,REASON) ;Clean it out
- N LRAA,LRAD,LRAN,X,LRTSN,LRUSNM
- ;I $D(^LRO(69,LRODT,1,LRSN,3)),$P(^(3),"^",2) S LREND=1 D ACK^LR7OF0("UC",LRXORC,"Tests already verified") Q ;Tests already verified
- S X=+^LRO(69,LRODT,1,LRSN,2,TST,0),LRTSN=+X,LRAD=+$P(X,"^",3),LRAA=+$P(X,"^",4),LRAN=+$P(X,"^",5)
- I LRAD,LRAA,LRAN,$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LREND=1 D ACK^LR7OF0("UC",LRXORC,"Tests already accessioned, contact lab to cancel") Q
- S $P(^LRO(69,LRODT,1,LRSN,2,TST,0),"^",3,6)="^^^",$P(^(0),"^",9,11)="CA^W^"_LRDUZ
- I $L($P(REASON,"^",5)) S:'$D(^LRO(69,LRODT,1,LRSN,2,TST,1.1,0)) ^(0)="^^^^"_DT S X=1+$O(^(9999),-1),$P(^LRO(69,LRODT,1,LRSN,2,TST,1.1,0),"^",3,4)=X_"^"_X,^(X,0)=$P(REASON,"^",5)
- Q
- CHKCOMB(LRODT,LRSN,LRIN,LRXORC,LRDUZ,REASON) ;
- ; check for other entries that have combined this test
- N LR60,LRI,LRORD,LRX,LRY
- ;
- ; retrieve list of merged orders
- S LRX=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7) Q:LRX=""
- ;
- S LR60=$P(^LRO(69,LRODT,1,LRSN,2,LRIN,0),"^")
- S LRY=LRODT_";"_LRSN_";"_LRIN
- ;
- ; scan the merged order # (LRX) and check corresponding orders/seq (LRSN)
- ; for matching (#20) COMBINED FROM [14F] and update if match
- F LRI=1:1 S LRORD=$P(LRX,"/",LRI) Q:LRORD="" D
- . S LRODT=0
- . F S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 D
- . . S LRSN=0
- . . F S LRSN=$O(^LRO(69,"C",LRORD,LRODT,LRSN)) Q:LRSN<1 D
- . . . S LRIN=$O(^LRO(69,LRODT,1,LRSN,2,"B",LR60,0))
- . . . I LRIN,$P(^LRO(69,LRODT,1,LRSN,2,LRIN,0),"^",14)=LRY D DOIT(LRODT,LRSN,LRIN,LRXORC,LRDUZ,REASON)
- ;
- Q
- NUM ;Process Return of OE/RR Order number
- N LRODT,LRSN,LRORD,ORIFN,STARTDT,LRDUZ,PROV,REASON,QUANT
- D GET(.LRXMSG,LRXORC) Q:LREND
- I 'LRVERZ,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)) S $P(^(0),"^",11)=ORIFN
- I LRVERZ,$D(^LRO(69,LRODT,1,LRSN,0)) S $P(^(0),"^",11)=ORIFN
- Q
- NA ;Set ORIFN at test level
- N I,X,LRODT,LRSN,LRORD,ORIFN,STARTDT,LRDUZ,PROV,REASON,QUANT,LRTXI
- D GET(.LRXORC,LRXORC) Q:LREND
- S I=0
- S X=$P($P(LRXMSG,"|",5),"^",4),LRTXI=0
- NA1 ;
- ;LR*5.2*538 - allow for the fact that a test might exist on more than
- ; one subscript
- I X S I=$O(^LRO(69,LRODT,1,LRSN,2,"B",X,LRTXI))
- I I,$P($G(^LRO(69,LRODT,1,LRSN,2,I,0)),"^",9)="CA" S LRTXI=I G NA1
- I I S $P(^LRO(69,LRODT,1,LRSN,2,I,0),"^",7)=ORIFN
- Q
- GET(XMSG,XORC) ;Get identification data from message
- ;ORIFN= OE/RR order number
- ;STARTDT= Start D/T of order
- ;LRDUZ= Entered by Person (ptr to file 200)
- ;PROV= Ordering Provider
- ;REASON= Order control reason (e.g. inadequate specimen)
- ;QUANT= Quantity ordered
- ;LRORD=Lab Order #
- ;LRODT=Order date
- ;LRSN=Specimen Number
- ;LRVERZ=0 if only LRORD, 1 if LRODT,LRSN exists. Used to maintain backward compatibility at Tuscaloosa when only LRORD was used.
- N X,X1,I,J,CTR
- S X=$P(XMSG,"|",4),LRORD=+X,LRODT=+$P(X,";",2),LRSN=+$P(X,";",3),LRVERZ=$S(LRODT&LRSN:1,1:0)
- S LRPLACR=$P(XMSG,"|",3),ORIFN=+LRPLACR
- I 'ORIFN D ACK^LR7OF0("DE",XORC,"OE/RR order number not passed") S LREND=1 Q
- I '$O(XMSG(0)) S STARTDT=$$FMDATE^LR7OU0($P($P(XMSG,"|",8),"^",4)),LRDUZ=$P(XMSG,"|",11),PROV=$P(XMSG,"|",13),REASON=$P(XMSG,"|",17),QUANT=$P($P(XMSG,"|",8),"^") Q
- F CTR=1:1:$L(XMSG,"|") S X1(CTR)=$P(XMSG,"|",CTR)
- S J=0 F S J=$O(XMSG(J)) Q:J<1 D
- . S I=1 I $E(XMSG(J))'="|" S X1(CTR)=X1(CTR)_$P(XMSG(J),"|"),I=I+1
- . F I=I:1:$L(XMSG(J),"|") S CTR=CTR+1,X1(CTR)=$P(XMSG(J),"|",I)
- S STARTDT=$$FMDATE^LR7OU0($P(X1(8),"^",4))
- S QUANT=$P(X1(8),"^")
- S LRDUZ=X1(11),PROV=X1(13),REASON=X1(17)
- Q
- NTE ;Process Order comments from OE/RR
- ;MSG(i)="NTE|1|P|comment..."
- ;MSG(i,c)="...more comments..."
- N X,I,LINES
- S X=$D(STARTDT)&($D(TYPE))&($D(SAMP))&($D(SPEC))&($D(LRSX))
- I 'X Q ;Trying to add comments to undefined test array in ^TMP
- I '$D(^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX)) Q ;Trying to add comments to undefined test array in ^TMP
- S:'$D(^TMP("OR",$J,"COM",STARTDT,TYPE,SAMP,SPEC,LRSX)) ^(LRSX)=0 S LINES=^(LRSX)
- I $L($P(LRXMSG,"|",4)) D N1($P(LRXMSG,"|",4))
- S I=0 F S I=$O(MSG(LINE,I)) Q:I<1 I $L(MSG(LINE,I)) D N1(MSG(LINE,I))
- Q
- N1(X) ;
- S LINES=LINES+1,^TMP("OR",$J,"COM",STARTDT,TYPE,SAMP,SPEC,LRSX,LINES)=X,^TMP("OR",$J,"COM",STARTDT,TYPE,SAMP,SPEC,LRSX)=LINES
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OF2 5890 printed Jan 18, 2025@03:05:41 Page 2
- LR7OF2 ;SLC/DCM - Process messages from OE/RR ;Mar 18, 2022@16:55
- +1 ;;5.2;LAB SERVICE;**121,187,440,538,557**;Sep 27, 1994;Build 2
- +2 ;
- NEW ;Process New orders from OE/RR
- +1 ;LRXMSG=Message with linking identifiers
- +2 ;LRXORC=Current ORC message value - for communicating back to OE/RR
- +3 DO GET(.LRXMSG,LRXORC)
- if LREND
- QUIT
- +4 IF '$LENGTH(STARTDT)
- DO ACK^LR7OF0("DE",LRXORC,"Start date not passed in message")
- SET LREND=1
- QUIT
- +5 IF '$LENGTH(LRDUZ)
- DO ACK^LR7OF0("DE",LRXORC,"Entered By person not passed in message")
- SET LREND=1
- QUIT
- +6 IF '$LENGTH(PROV)
- DO ACK^LR7OF0("DE",LRXORC,"Provider not passed in message")
- SET LREND=1
- QUIT
- +7 QUIT
- CANC ;Process Canceled orders from OE/RR
- +1 NEW TST,X,LRODT,LRSN,LRORD,LRORIFN,STARTDT,LRDUZ,PROV,REASON,QUANT
- +2 DO GET(.LRXORC,LRXORC)
- if LREND
- QUIT
- +3 IF 'LRVERZ
- 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
- Begin DoDot:1
- +4 SET X=$PIECE($PIECE(LRXMSG,"|",5),"^",4)
- IF X
- SET TST=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",X,0))
- IF TST
- DO DOIT(LRODT,LRSN,TST,LRXORC,LRDUZ,REASON)
- if LREND
- QUIT
- End DoDot:1
- QUIT
- +5 IF LRVERZ
- IF $DATA(^LRO(69,LRODT,1,LRSN,0))
- Begin DoDot:1
- +6 SET X=$PIECE($PIECE(LRXMSG,"|",5),"^",4)
- SET TST=""
- +7 IF X
- SET TST=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",X,0))
- +8 IF TST
- DO DOIT(LRODT,LRSN,TST,LRXORC,LRDUZ,REASON)
- Begin DoDot:2
- +9 ;LR*5.2*557: If line below is invoked for VBECS-originated
- +10 ; cancellations, VistA status will not update correctly.
- +11 IF $GET(ORNMSP)'="VBEC"
- DO CHKCOMB(LRODT,LRSN,TST,LRXORC,LRDUZ,REASON)
- End DoDot:2
- End DoDot:1
- if LREND
- QUIT
- +12 DO ACK^LR7OF0("CR",LRXORC)
- +13 QUIT
- XO ;Process order changes from OE/RR
- +1 DO GET(.LRXMSG,LRXORC)
- if LREND
- QUIT
- +2 DO ACK^LR7OF0("XR",LRXORC)
- +3 QUIT
- DOIT(LRODT,LRSN,TST,LRXORC,LRDUZ,REASON) ;Clean it out
- +1 NEW LRAA,LRAD,LRAN,X,LRTSN,LRUSNM
- +2 ;I $D(^LRO(69,LRODT,1,LRSN,3)),$P(^(3),"^",2) S LREND=1 D ACK^LR7OF0("UC",LRXORC,"Tests already verified") Q ;Tests already verified
- +3 SET X=+^LRO(69,LRODT,1,LRSN,2,TST,0)
- SET LRTSN=+X
- SET LRAD=+$PIECE(X,"^",3)
- SET LRAA=+$PIECE(X,"^",4)
- SET LRAN=+$PIECE(X,"^",5)
- +4 IF LRAD
- IF LRAA
- IF LRAN
- IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
- SET LREND=1
- DO ACK^LR7OF0("UC",LRXORC,"Tests already accessioned, contact lab to cancel")
- QUIT
- +5 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,TST,0),"^",3,6)="^^^"
- SET $PIECE(^(0),"^",9,11)="CA^W^"_LRDUZ
- +6 IF $LENGTH($PIECE(REASON,"^",5))
- if '$DATA(^LRO(69,LRODT,1,LRSN,2,TST,1.1,0))
- SET ^(0)="^^^^"_DT
- SET X=1+$ORDER(^(9999),-1)
- SET $PIECE(^LRO(69,LRODT,1,LRSN,2,TST,1.1,0),"^",3,4)=X_"^"_X
- SET ^(X,0)=$PIECE(REASON,"^",5)
- +7 QUIT
- CHKCOMB(LRODT,LRSN,LRIN,LRXORC,LRDUZ,REASON) ;
- +1 ; check for other entries that have combined this test
- +2 NEW LR60,LRI,LRORD,LRX,LRY
- +3 ;
- +4 ; retrieve list of merged orders
- +5 SET LRX=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),"^",7)
- if LRX=""
- QUIT
- +6 ;
- +7 SET LR60=$PIECE(^LRO(69,LRODT,1,LRSN,2,LRIN,0),"^")
- +8 SET LRY=LRODT_";"_LRSN_";"_LRIN
- +9 ;
- +10 ; scan the merged order # (LRX) and check corresponding orders/seq (LRSN)
- +11 ; for matching (#20) COMBINED FROM [14F] and update if match
- +12 FOR LRI=1:1
- SET LRORD=$PIECE(LRX,"/",LRI)
- if LRORD=""
- QUIT
- Begin DoDot:1
- +13 SET LRODT=0
- +14 FOR
- SET LRODT=$ORDER(^LRO(69,"C",LRORD,LRODT))
- if LRODT<1
- QUIT
- Begin DoDot:2
- +15 SET LRSN=0
- +16 FOR
- SET LRSN=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSN))
- if LRSN<1
- QUIT
- Begin DoDot:3
- +17 SET LRIN=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LR60,0))
- +18 IF LRIN
- IF $PIECE(^LRO(69,LRODT,1,LRSN,2,LRIN,0),"^",14)=LRY
- DO DOIT(LRODT,LRSN,LRIN,LRXORC,LRDUZ,REASON)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +19 ;
- +20 QUIT
- NUM ;Process Return of OE/RR Order number
- +1 NEW LRODT,LRSN,LRORD,ORIFN,STARTDT,LRDUZ,PROV,REASON,QUANT
- +2 DO GET(.LRXMSG,LRXORC)
- if LREND
- QUIT
- +3 IF 'LRVERZ
- IF LRORD
- 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 $PIECE(^(0),"^",11)=ORIFN
- +4 IF LRVERZ
- IF $DATA(^LRO(69,LRODT,1,LRSN,0))
- SET $PIECE(^(0),"^",11)=ORIFN
- +5 QUIT
- NA ;Set ORIFN at test level
- +1 NEW I,X,LRODT,LRSN,LRORD,ORIFN,STARTDT,LRDUZ,PROV,REASON,QUANT,LRTXI
- +2 DO GET(.LRXORC,LRXORC)
- if LREND
- QUIT
- +3 SET I=0
- +4 SET X=$PIECE($PIECE(LRXMSG,"|",5),"^",4)
- SET LRTXI=0
- NA1 ;
- +1 ;LR*5.2*538 - allow for the fact that a test might exist on more than
- +2 ; one subscript
- +3 IF X
- SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",X,LRTXI))
- +4 IF I
- IF $PIECE($GET(^LRO(69,LRODT,1,LRSN,2,I,0)),"^",9)="CA"
- SET LRTXI=I
- GOTO NA1
- +5 IF I
- SET $PIECE(^LRO(69,LRODT,1,LRSN,2,I,0),"^",7)=ORIFN
- +6 QUIT
- GET(XMSG,XORC) ;Get identification data from message
- +1 ;ORIFN= OE/RR order number
- +2 ;STARTDT= Start D/T of order
- +3 ;LRDUZ= Entered by Person (ptr to file 200)
- +4 ;PROV= Ordering Provider
- +5 ;REASON= Order control reason (e.g. inadequate specimen)
- +6 ;QUANT= Quantity ordered
- +7 ;LRORD=Lab Order #
- +8 ;LRODT=Order date
- +9 ;LRSN=Specimen Number
- +10 ;LRVERZ=0 if only LRORD, 1 if LRODT,LRSN exists. Used to maintain backward compatibility at Tuscaloosa when only LRORD was used.
- +11 NEW X,X1,I,J,CTR
- +12 SET X=$PIECE(XMSG,"|",4)
- SET LRORD=+X
- SET LRODT=+$PIECE(X,";",2)
- SET LRSN=+$PIECE(X,";",3)
- SET LRVERZ=$SELECT(LRODT&LRSN:1,1:0)
- +13 SET LRPLACR=$PIECE(XMSG,"|",3)
- SET ORIFN=+LRPLACR
- +14 IF 'ORIFN
- DO ACK^LR7OF0("DE",XORC,"OE/RR order number not passed")
- SET LREND=1
- QUIT
- +15 IF '$ORDER(XMSG(0))
- SET STARTDT=$$FMDATE^LR7OU0($PIECE($PIECE(XMSG,"|",8),"^",4))
- SET LRDUZ=$PIECE(XMSG,"|",11)
- SET PROV=$PIECE(XMSG,"|",13)
- SET REASON=$PIECE(XMSG,"|",17)
- SET QUANT=$PIECE($PIECE(XMSG,"|",8),"^")
- QUIT
- +16 FOR CTR=1:1:$LENGTH(XMSG,"|")
- SET X1(CTR)=$PIECE(XMSG,"|",CTR)
- +17 SET J=0
- FOR
- SET J=$ORDER(XMSG(J))
- if J<1
- QUIT
- Begin DoDot:1
- +18 SET I=1
- IF $EXTRACT(XMSG(J))'="|"
- SET X1(CTR)=X1(CTR)_$PIECE(XMSG(J),"|")
- SET I=I+1
- +19 FOR I=I:1:$LENGTH(XMSG(J),"|")
- SET CTR=CTR+1
- SET X1(CTR)=$PIECE(XMSG(J),"|",I)
- End DoDot:1
- +20 SET STARTDT=$$FMDATE^LR7OU0($PIECE(X1(8),"^",4))
- +21 SET QUANT=$PIECE(X1(8),"^")
- +22 SET LRDUZ=X1(11)
- SET PROV=X1(13)
- SET REASON=X1(17)
- +23 QUIT
- NTE ;Process Order comments from OE/RR
- +1 ;MSG(i)="NTE|1|P|comment..."
- +2 ;MSG(i,c)="...more comments..."
- +3 NEW X,I,LINES
- +4 SET X=$DATA(STARTDT)&($DATA(TYPE))&($DATA(SAMP))&($DATA(SPEC))&($DATA(LRSX))
- +5 ;Trying to add comments to undefined test array in ^TMP
- IF 'X
- QUIT
- +6 ;Trying to add comments to undefined test array in ^TMP
- IF '$DATA(^TMP("OR",$JOB,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX))
- QUIT
- +7 if '$DATA(^TMP("OR",$JOB,"COM",STARTDT,TYPE,SAMP,SPEC,LRSX))
- SET ^(LRSX)=0
- SET LINES=^(LRSX)
- +8 IF $LENGTH($PIECE(LRXMSG,"|",4))
- DO N1($PIECE(LRXMSG,"|",4))
- +9 SET I=0
- FOR
- SET I=$ORDER(MSG(LINE,I))
- if I<1
- QUIT
- IF $LENGTH(MSG(LINE,I))
- DO N1(MSG(LINE,I))
- +10 QUIT
- N1(X) ;
- +1 SET LINES=LINES+1
- SET ^TMP("OR",$JOB,"COM",STARTDT,TYPE,SAMP,SPEC,LRSX,LINES)=X
- SET ^TMP("OR",$JOB,"COM",STARTDT,TYPE,SAMP,SPEC,LRSX)=LINES
- +2 QUIT