PXRMPLAB ;SLC/AGP,RFR - Reminder Order Protocol Incoming from Lab ;Jan 18, 2023@12:55
;;2.0;CLINICAL REMINDERS;**45,71,84**;Feb 04, 2005;Build 2
Q
;
;SAC EXEMPTION 20030908-01 : Use proper variable scoping instead of
; namespace variable scoping
;
;Reference to ^OR(100, in ICR #3800
;Reference to GETRECIPS^WVRPCPT1 in ICR #6200
;Reference to $$SAVESRND^WVRPCPT1 in ICR #6336
;
EN(MSG) ;
N PXRMMSG,$ETRAP,$ESTACK
S $ETRAP="G UNEXPERR^PXRMPLAB"
S PXRMMSG=$S($L($G(MSG)):MSG,1:"MSG") Q:'$O(@PXRMMSG@(0))
N APPL,BEGDATE,CNTRL,DATE,ERROR,ITEMIEN,LOC,MATCH,MSH,NODE,OBR,ORDIEN,ORC,PAT,PID,PROV
N TERMARR,PKGIFN,OBX,DATA,EXIT,PXRMPROV,MUC,ITEM,ITEMTYPE,STATUS,PXRMVASITE
S MSH=0 F S MSH=$O(@PXRMMSG@(MSH)) Q:MSH'>0 Q:$E(@PXRMMSG@(MSH),1,3)="MSH"
I 'MSH D ERROR("Missing or invalid MSH segment",.ERROR) G ORX
S APPL=$P(@PXRMMSG@(MSH),"|",3) I '$$VALIDAPL(APPL) G ORX
S PXRMVASITE=$P(@PXRMMSG@(MSH),"|",4)
D PID(.PXRMMSG,MSH,.PID,.PAT) I PAT'>0 D ERROR("Missing patient in HL7 message",.ERROR) G ORX
S ORC=PID
;
ORC ;process the ORC segments
S MATCH=0
F S ORC=$O(@PXRMMSG@(+ORC)) Q:ORC'>0 I $E(@PXRMMSG@(ORC),1,3)="ORC" D Q
. S ORC=ORC_U_@PXRMMSG@(ORC),CNTRL=$TR($P(ORC,"|",2),"@","P")
. I '$L(CNTRL) D ERROR("Invalid control code in HL7 message") Q
. I '$$VALIDCTL(APPL,CNTRL) Q
. S ORDIEN=$P($P(ORC,"|",3),U),PKGIFN=$P($P(ORC,"|",4),U)
. I ORDIEN,$D(^OR(100,+ORDIEN,0)),+$P(^(0),U,2)'=PAT D ERROR("Patient doesn't match between the Order and HL7 message",.ERROR) Q
. S MATCH=1
. S DATE=$P($G(^OR(100,+ORDIEN,0)),U,7),LOC=+$P($G(^OR(100,+ORDIEN,0)),U,10)
. S PROV=$P($P(ORC,"|",13),U)
I MATCH=0 G ORX
S OBR=ORC
;
OBR ;process the OBR segments
F S OBR=$O(@PXRMMSG@(+OBR)) Q:OBR'>0 I $E(@PXRMMSG@(OBR),1,3)="OBR" D Q
.S BEGDATE=$P(@PXRMMSG@(OBR),"|",8)
.I BEGDATE'="" S BEGDATE=$$HL7TFM^XLFDT(BEGDATE,"L")
S ITEMTYPE=$$GETTYPE(APPL)
I $G(ITEMTYPE)="" G ORX
;
OBX ;process the OBX segments
S OBX=+OBR,STATUS=0
F S OBX=$O(@PXRMMSG@(OBX)) Q:'+OBX!($G(EXIT)) D
.I $E(@PXRMMSG@(OBX),1,3)'="OBX" S EXIT=1,OBX=OBX-1 Q
.S NODE=$P(@PXRMMSG@(OBX),"|",4) I NODE="" Q
.S ITEMIEN=+$P(NODE,U,4),ITEM=$P(NODE,U,5)
.I ITEMIEN'>0!(ITEM="") Q
.I $$EVAL(PAT,ITEMIEN,ITEM,ITEMTYPE,$P($G(BEGDATE),"."),PROV,$G(DATE),$G(LOC),.PXRMPROV,.ERROR,.MUC,PXRMVASITE)>0 D
..S DATA("ID")=PAT_U_"P"
..S DATA("LAB")=BEGDATE_"|"_$P(@PXRMMSG@(OBX),"|",4,8)
..S STATUS=$$SAVESRND^WVRPCPT1(.DATA)
..I +STATUS=-1 D ERROR("Error saving status conflict notification data: "_$P(STATUS,U,2),.ERROR) Q
..I STATUS=1 D TALERT^PXRMNTFY(PAT,.PXRMPROV,1,.MUC)
.I $D(ERROR) S EXIT=1
ORX ;
I $D(ERROR) D SENDERR(.ERROR)
Q
;
UNEXPERR ;unexpected error handler
N ERROR
D ERROR("An unexpected error was encountered: "_$$EC^%ZOSV,.ERROR)
D SENDERR(.ERROR)
D @^%ZOSF("ERRTN") ;file error
S $ECODE=""
Q ""
ERROR(TEXT,ERROR) ;
N CNT,DATA,INDEX
S CNT=$O(ERROR("?"),-1)+1
S ERROR(CNT,0)=TEXT,CNT=CNT+1
S ERROR(CNT,0)="",CNT=CNT+1
S ERROR(CNT,0)="The contents of the HL7 message that triggered this error:"
D ACOPY^PXRMUTIL($S(PXRMMSG[U:$P(PXRMMSG,",")_")",1:"MSG"),"DATA()")
S INDEX=0 F S INDEX=$O(DATA(INDEX)) Q:INDEX'>0 S CNT=CNT+1,ERROR(CNT,0)=DATA(INDEX)
Q
;
EVAL(PAT,ITEMIEN,ITEM,ITEMTYPE,BEGDATE,PROV,DATE,LOC,PXRMPROV,ERROR,MUC,PXRMVASITE) ;evaluation of a reminder
N DEFARR,FIEV,NAME,NODE,PXRMSDT,RESULT,RIEN,RNAME,STATUS,TNAME,TERMARR
N CONT,PCP
S RESULT=0
;check terms to see if test should trigger an evaluation
F TNAME="VA-WH POSITIVE LAB PREGNANCY TEST","VA-WH NEGATIVE LAB PREGNANCY TEST" D Q:$G(CONT)
.D TERM^PXRMLDR(TNAME,.TERMARR) I $D(TERMARR("DNE")) D ERROR("Reminder Term "_TNAME_" not found",.ERROR) G EVALX
.I $D(TERMARR("E",ITEMTYPE,ITEMIEN)) S CONT=1
G:'$G(CONT) EVALX
;set variables for reminder evaluation
K ^TMP("PXRHM",$J)
S PXRMSDT=$S(BEGDATE>0:BEGDATE,1:DT),NAME="VA-WH CHANGE IN PREGNANCY STATUS"
S RIEN=$O(^PXD(811.9,"B",NAME,"")) I RIEN'>0 D ERROR("Reminder Definition "_NAME_" not found",.ERROR) G EVALX
S NODE=$G(^PXD(811.9,RIEN,0))
S RNAME=$S($P(NODE,U,3)'="":$P(NODE,U,3),1:$P(NODE,U))
;may be able to switch to call MAIN
D DEF^PXRMLDR(RIEN,.DEFARR)
D EVAL^PXRM(PAT,.DEFARR,1,1,.FIEV,PXRMSDT)
S STATUS=$P($G(^TMP("PXRHM",$J,RIEN,RNAME)),U)
K ^TMP("PXRHM",$J)
I (STATUS="CNBD")!(STATUS="ERROR") D ERROR("Error evaluating Reminder Definition "_NAME,.ERROR) G EVALX
S RESULT=$$STATMTCH^PXRMORCH(STATUS,"D")
;FIEV(4)=1 => MEDICALLY UNABLE TO CONCEIVE
S MUC=$S($G(FIEV(4)):1,1:0)
I RESULT=1 D
.D GETRECIPS^WVRPCPT1(.PXRMPROV,PAT,"LAB","P",0,PXRMVASITE)
.I +$G(PXRMPROV(0))=-1 D
..S RESULT=0
..D ERROR("Error retrieving Women's Health managers: "_$P(PXRMPROV(0),U,2),.ERROR) G EVALX
S PXRMPROV(PROV)=""
EVALX ;
Q RESULT
;
GETTYPE(APPL) ;
I APPL="LABORATORY" Q "LAB(60,"
Q ""
;
SENDERR(ERROR) ;
K ^TMP("PXRMXMZ",$J)
M ^TMP("PXRMXMZ",$J)=ERROR
D SEND^PXRMMSG("PXRMXMZ","Clinical Reminder Laboratory HL7 listener.")
K ^TMP("PXRMXMZ",$J)
Q
;
VALIDCTL(APPL,CNTRL) ;
N RESULT
S RESULT=0
I APPL="LABORATORY" D Q RESULT
.I CNTRL="CM" S RESULT=1 Q
.I CNTRL="RE" S RESULT=1 Q
Q RESULT
;
VALIDAPL(APPL) ;
I APPL="LABORATORY" Q 1
Q 0
;
PID(PXRMMSG,MSH,PID,PAT) ; -- Returns patient from PID segment in current msg
N DFN,I,SEG S I=MSH,PID=""
F S I=$O(@PXRMMSG@(I)) Q:I'>0 S SEG=$E(@PXRMMSG@(I),1,3) Q:SEG="ORC" I SEG="PID" D Q
. S DFN=+$P(@PXRMMSG@(I),"|",4),PID=I
. I $D(^DPT(DFN,0)) S PAT=DFN Q
. S:$L($P(@PXRMMSG@(I),"|",5)) PAT=+$P(@PXRMMSG@(I),"|",5) ; alt ID for Lab
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMPLAB 5648 printed Dec 13, 2024@01:48:33 Page 2
PXRMPLAB ;SLC/AGP,RFR - Reminder Order Protocol Incoming from Lab ;Jan 18, 2023@12:55
+1 ;;2.0;CLINICAL REMINDERS;**45,71,84**;Feb 04, 2005;Build 2
+2 QUIT
+3 ;
+4 ;SAC EXEMPTION 20030908-01 : Use proper variable scoping instead of
+5 ; namespace variable scoping
+6 ;
+7 ;Reference to ^OR(100, in ICR #3800
+8 ;Reference to GETRECIPS^WVRPCPT1 in ICR #6200
+9 ;Reference to $$SAVESRND^WVRPCPT1 in ICR #6336
+10 ;
EN(MSG) ;
+1 NEW PXRMMSG,$ETRAP,$ESTACK
+2 SET $ETRAP="G UNEXPERR^PXRMPLAB"
+3 SET PXRMMSG=$SELECT($LENGTH($GET(MSG)):MSG,1:"MSG")
if '$ORDER(@PXRMMSG@(0))
QUIT
+4 NEW APPL,BEGDATE,CNTRL,DATE,ERROR,ITEMIEN,LOC,MATCH,MSH,NODE,OBR,ORDIEN,ORC,PAT,PID,PROV
+5 NEW TERMARR,PKGIFN,OBX,DATA,EXIT,PXRMPROV,MUC,ITEM,ITEMTYPE,STATUS,PXRMVASITE
+6 SET MSH=0
FOR
SET MSH=$ORDER(@PXRMMSG@(MSH))
if MSH'>0
QUIT
if $EXTRACT(@PXRMMSG@(MSH),1,3)="MSH"
QUIT
+7 IF 'MSH
DO ERROR("Missing or invalid MSH segment",.ERROR)
GOTO ORX
+8 SET APPL=$PIECE(@PXRMMSG@(MSH),"|",3)
IF '$$VALIDAPL(APPL)
GOTO ORX
+9 SET PXRMVASITE=$PIECE(@PXRMMSG@(MSH),"|",4)
+10 DO PID(.PXRMMSG,MSH,.PID,.PAT)
IF PAT'>0
DO ERROR("Missing patient in HL7 message",.ERROR)
GOTO ORX
+11 SET ORC=PID
+12 ;
ORC ;process the ORC segments
+1 SET MATCH=0
+2 FOR
SET ORC=$ORDER(@PXRMMSG@(+ORC))
if ORC'>0
QUIT
IF $EXTRACT(@PXRMMSG@(ORC),1,3)="ORC"
Begin DoDot:1
+3 SET ORC=ORC_U_@PXRMMSG@(ORC)
SET CNTRL=$TRANSLATE($PIECE(ORC,"|",2),"@","P")
+4 IF '$LENGTH(CNTRL)
DO ERROR("Invalid control code in HL7 message")
QUIT
+5 IF '$$VALIDCTL(APPL,CNTRL)
QUIT
+6 SET ORDIEN=$PIECE($PIECE(ORC,"|",3),U)
SET PKGIFN=$PIECE($PIECE(ORC,"|",4),U)
+7 IF ORDIEN
IF $DATA(^OR(100,+ORDIEN,0))
IF +$PIECE(^(0),U,2)'=PAT
DO ERROR("Patient doesn't match between the Order and HL7 message",.ERROR)
QUIT
+8 SET MATCH=1
+9 SET DATE=$PIECE($GET(^OR(100,+ORDIEN,0)),U,7)
SET LOC=+$PIECE($GET(^OR(100,+ORDIEN,0)),U,10)
+10 SET PROV=$PIECE($PIECE(ORC,"|",13),U)
End DoDot:1
QUIT
+11 IF MATCH=0
GOTO ORX
+12 SET OBR=ORC
+13 ;
OBR ;process the OBR segments
+1 FOR
SET OBR=$ORDER(@PXRMMSG@(+OBR))
if OBR'>0
QUIT
IF $EXTRACT(@PXRMMSG@(OBR),1,3)="OBR"
Begin DoDot:1
+2 SET BEGDATE=$PIECE(@PXRMMSG@(OBR),"|",8)
+3 IF BEGDATE'=""
SET BEGDATE=$$HL7TFM^XLFDT(BEGDATE,"L")
End DoDot:1
QUIT
+4 SET ITEMTYPE=$$GETTYPE(APPL)
+5 IF $GET(ITEMTYPE)=""
GOTO ORX
+6 ;
OBX ;process the OBX segments
+1 SET OBX=+OBR
SET STATUS=0
+2 FOR
SET OBX=$ORDER(@PXRMMSG@(OBX))
if '+OBX!($GET(EXIT))
QUIT
Begin DoDot:1
+3 IF $EXTRACT(@PXRMMSG@(OBX),1,3)'="OBX"
SET EXIT=1
SET OBX=OBX-1
QUIT
+4 SET NODE=$PIECE(@PXRMMSG@(OBX),"|",4)
IF NODE=""
QUIT
+5 SET ITEMIEN=+$PIECE(NODE,U,4)
SET ITEM=$PIECE(NODE,U,5)
+6 IF ITEMIEN'>0!(ITEM="")
QUIT
+7 IF $$EVAL(PAT,ITEMIEN,ITEM,ITEMTYPE,$PIECE($GET(BEGDATE),"."),PROV,$GET(DATE),$GET(LOC),.PXRMPROV,.ERROR,.MUC,PXRMVASITE)>0
Begin DoDot:2
+8 SET DATA("ID")=PAT_U_"P"
+9 SET DATA("LAB")=BEGDATE_"|"_$PIECE(@PXRMMSG@(OBX),"|",4,8)
+10 SET STATUS=$$SAVESRND^WVRPCPT1(.DATA)
+11 IF +STATUS=-1
DO ERROR("Error saving status conflict notification data: "_$PIECE(STATUS,U,2),.ERROR)
QUIT
+12 IF STATUS=1
DO TALERT^PXRMNTFY(PAT,.PXRMPROV,1,.MUC)
End DoDot:2
+13 IF $DATA(ERROR)
SET EXIT=1
End DoDot:1
ORX ;
+1 IF $DATA(ERROR)
DO SENDERR(.ERROR)
+2 QUIT
+3 ;
UNEXPERR ;unexpected error handler
+1 NEW ERROR
+2 DO ERROR("An unexpected error was encountered: "_$$EC^%ZOSV,.ERROR)
+3 DO SENDERR(.ERROR)
+4 ;file error
DO @^%ZOSF("ERRTN")
+5 SET $ECODE=""
+6 QUIT ""
ERROR(TEXT,ERROR) ;
+1 NEW CNT,DATA,INDEX
+2 SET CNT=$ORDER(ERROR("?"),-1)+1
+3 SET ERROR(CNT,0)=TEXT
SET CNT=CNT+1
+4 SET ERROR(CNT,0)=""
SET CNT=CNT+1
+5 SET ERROR(CNT,0)="The contents of the HL7 message that triggered this error:"
+6 DO ACOPY^PXRMUTIL($SELECT(PXRMMSG[U:$PIECE(PXRMMSG,",")_")",1:"MSG"),"DATA()")
+7 SET INDEX=0
FOR
SET INDEX=$ORDER(DATA(INDEX))
if INDEX'>0
QUIT
SET CNT=CNT+1
SET ERROR(CNT,0)=DATA(INDEX)
+8 QUIT
+9 ;
EVAL(PAT,ITEMIEN,ITEM,ITEMTYPE,BEGDATE,PROV,DATE,LOC,PXRMPROV,ERROR,MUC,PXRMVASITE) ;evaluation of a reminder
+1 NEW DEFARR,FIEV,NAME,NODE,PXRMSDT,RESULT,RIEN,RNAME,STATUS,TNAME,TERMARR
+2 NEW CONT,PCP
+3 SET RESULT=0
+4 ;check terms to see if test should trigger an evaluation
+5 FOR TNAME="VA-WH POSITIVE LAB PREGNANCY TEST","VA-WH NEGATIVE LAB PREGNANCY TEST"
Begin DoDot:1
+6 DO TERM^PXRMLDR(TNAME,.TERMARR)
IF $DATA(TERMARR("DNE"))
DO ERROR("Reminder Term "_TNAME_" not found",.ERROR)
GOTO EVALX
+7 IF $DATA(TERMARR("E",ITEMTYPE,ITEMIEN))
SET CONT=1
End DoDot:1
if $GET(CONT)
QUIT
+8 if '$GET(CONT)
GOTO EVALX
+9 ;set variables for reminder evaluation
+10 KILL ^TMP("PXRHM",$JOB)
+11 SET PXRMSDT=$SELECT(BEGDATE>0:BEGDATE,1:DT)
SET NAME="VA-WH CHANGE IN PREGNANCY STATUS"
+12 SET RIEN=$ORDER(^PXD(811.9,"B",NAME,""))
IF RIEN'>0
DO ERROR("Reminder Definition "_NAME_" not found",.ERROR)
GOTO EVALX
+13 SET NODE=$GET(^PXD(811.9,RIEN,0))
+14 SET RNAME=$SELECT($PIECE(NODE,U,3)'="":$PIECE(NODE,U,3),1:$PIECE(NODE,U))
+15 ;may be able to switch to call MAIN
+16 DO DEF^PXRMLDR(RIEN,.DEFARR)
+17 DO EVAL^PXRM(PAT,.DEFARR,1,1,.FIEV,PXRMSDT)
+18 SET STATUS=$PIECE($GET(^TMP("PXRHM",$JOB,RIEN,RNAME)),U)
+19 KILL ^TMP("PXRHM",$JOB)
+20 IF (STATUS="CNBD")!(STATUS="ERROR")
DO ERROR("Error evaluating Reminder Definition "_NAME,.ERROR)
GOTO EVALX
+21 SET RESULT=$$STATMTCH^PXRMORCH(STATUS,"D")
+22 ;FIEV(4)=1 => MEDICALLY UNABLE TO CONCEIVE
+23 SET MUC=$SELECT($GET(FIEV(4)):1,1:0)
+24 IF RESULT=1
Begin DoDot:1
+25 DO GETRECIPS^WVRPCPT1(.PXRMPROV,PAT,"LAB","P",0,PXRMVASITE)
+26 IF +$GET(PXRMPROV(0))=-1
Begin DoDot:2
+27 SET RESULT=0
+28 DO ERROR("Error retrieving Women's Health managers: "_$PIECE(PXRMPROV(0),U,2),.ERROR)
GOTO EVALX
End DoDot:2
End DoDot:1
+29 SET PXRMPROV(PROV)=""
EVALX ;
+1 QUIT RESULT
+2 ;
GETTYPE(APPL) ;
+1 IF APPL="LABORATORY"
QUIT "LAB(60,"
+2 QUIT ""
+3 ;
SENDERR(ERROR) ;
+1 KILL ^TMP("PXRMXMZ",$JOB)
+2 MERGE ^TMP("PXRMXMZ",$JOB)=ERROR
+3 DO SEND^PXRMMSG("PXRMXMZ","Clinical Reminder Laboratory HL7 listener.")
+4 KILL ^TMP("PXRMXMZ",$JOB)
+5 QUIT
+6 ;
VALIDCTL(APPL,CNTRL) ;
+1 NEW RESULT
+2 SET RESULT=0
+3 IF APPL="LABORATORY"
Begin DoDot:1
+4 IF CNTRL="CM"
SET RESULT=1
QUIT
+5 IF CNTRL="RE"
SET RESULT=1
QUIT
End DoDot:1
QUIT RESULT
+6 QUIT RESULT
+7 ;
VALIDAPL(APPL) ;
+1 IF APPL="LABORATORY"
QUIT 1
+2 QUIT 0
+3 ;
PID(PXRMMSG,MSH,PID,PAT) ; -- Returns patient from PID segment in current msg
+1 NEW DFN,I,SEG
SET I=MSH
SET PID=""
+2 FOR
SET I=$ORDER(@PXRMMSG@(I))
if I'>0
QUIT
SET SEG=$EXTRACT(@PXRMMSG@(I),1,3)
if SEG="ORC"
QUIT
IF SEG="PID"
Begin DoDot:1
+3 SET DFN=+$PIECE(@PXRMMSG@(I),"|",4)
SET PID=I
+4 IF $DATA(^DPT(DFN,0))
SET PAT=DFN
QUIT
+5 ; alt ID for Lab
if $LENGTH($PIECE(@PXRMMSG@(I),"|",5))
SET PAT=+$PIECE(@PXRMMSG@(I),"|",5)
End DoDot:1
QUIT
+6 QUIT
