Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRMPRAD

PXRMPRAD.m

Go to the documentation of this file.
PXRMPRAD ;SLC/AGP,RFR - Reminder Order Protocol Outgoing to Rad;12/18/2019
 ;;2.0;CLINICAL REMINDERS;**45**;Feb 04, 2005;Build 566
 Q
 ;ICR 586
EN(MSG) ;
 N PXRMMSG,$ETRAP,$ESTACK
 S $ETRAP="G UNEXPERR^PXRMPRAD"
 S PXRMMSG=$S($L($G(MSG)):MSG,1:"MSG") Q:'$O(@PXRMMSG@(0))
 N APPL,BEGDATE,CNTRL,CODE,CODESYS,DATE,ENDDATE,ERROR,ITEMIEN,LOC,MATCH,MSH,NODE,OBR,ORDIEN,ORC,PAT,PID,PROV
 N PXRMXDT,PARAMS,RADID,RADNAME,REMIEN,TERMIEN,TERMARR,PKGIFN,OBX,DATA,EXIT
 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),"|",5) I '$$VALIDAPL(APPL) G ORX
 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
 . ; figure out what to do with DC orders
 . I CNTRL="DC" 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,"|",11),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 OBR=OBR_U_@PXRMMSG@(OBR)
 .S NODE=$P(OBR,"|",5) I NODE="" Q
 .S CODE=$P(NODE,U),CODESYS=$P(NODE,U,3)
 .S RADID=$P(NODE,U,4),RADNAME=$P(NODE,U,5)
 S ITEMTYPE=$$GETTYPE(APPL)
 I $G(CODESYS)="",CODE="",RADID'>0 Q
 ; safety check to pull code from radiology procedure if not defined in OI.
 I CODE="",RADID>0 S CODE=$$GET1^DIQ(71,RADID_",",9,"")
 D EVAL(PAT,RADID,ITEMTYPE,CODE,CODESYS,ORDIEN,PROV,$G(DATE),$G(LOC),.ERROR)
ORX ;
 I $D(ERROR) D SENDERR(.ERROR)
 Q
 ;
EPISODE(ITEM,START,DATE) ;
 I DATE'>0 S DATE=$$NOW^XLFDT()
 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($P(PXRMMSG,",")_")","DATA()")
 S INDEX=0 F  S INDEX=$O(DATA(INDEX)) Q:INDEX'>0  S CNT=CNT+1,ERROR(CNT,0)=DATA(INDEX)
 Q
 ;
GETCODES(TXIEN,TNAME,TXARRAY) ;
 N CODE,CODESYS
 S CODESYS="" F  S CODESYS=$O(^PXD(811.2,TXIEN,20,"AE",CODESYS)) Q:CODESYS=""  D
 .I CODESYS'="CPT",CODESYS'="CPC" Q
 .S CODE="" F  S CODE=$O(^PXD(811.2,TXIEN,20,"AE",CODESYS,CODE)) Q:CODE=""  D
 ..S TXARRAY(CODE)=""
 Q
 ;
GETTRMCD(TIEN,TXARRAY,TERMARR,ERROR) ;
 N TNAME,TXIEN
 S TNAME=$P($G(^PXRMD(811.5,TIEN,0)),U) I TNAME="" S ERROR="Reminder Term IEN #"_TIEN_" not found" Q
 D TERM^PXRMLDR(TNAME,.TERMARR) I $D(TERMARR("DNE")) S ERROR="Reminder Term "_TNAME_" not found" Q
 I '$D(TERMARR("E","PXD(811.2,")) S ERROR="Reminder Term "_TNAME_" does not contain a taxonomy" Q
 S TXIEN=0 F  S TXIEN=$O(TERMARR("E","PXD(811.2,",TXIEN)) Q:TXIEN'>0  D GETCODES(TXIEN,TNAME,.TXARRAY)
 Q
 ;
CHCKPROC(INPUT,ERROR) ;
 N CODE,CODESYS,ITEM,ITEMTYPE,MAX,RESULT,START,TERMARR,TERMLARR,TNAME,TXARRAY,TXIEN,X
 S CODE=$G(INPUT("CODE")),CODESYS=$G(INPUT("CODESYS"))
 S ITEM=$G(INPUT("ITEM")),ITEMTYPE=$G(INPUT("ITEMTYPE"))
 S RESULT=0
 ;F TNAME="VA-WH MAMMOGRAM SCREENING CODES","VA-WH MAMMOGRAM BILAT DIAGNOSTIC CODES","VA-WH MAMMOGRAM UNILAT DIAGNOSTIC CODES","VA-WH MRI OF THE BREASTS CODES","VA-WH ULTRASOUND OF THE BREAST CODES" D  Q:$D(ERROR)!(+RESULT=1)
 S MAX=$$BLDTARR(.TERMLARR)
 F X=1:1:MAX D  Q:$D(ERROR)!(+RESULT=1)
 .S TNAME=TERMLARR(X)
 .K TERMARR
 .S START=$S(TNAME="VA-WH MAMMOGRAM SCREENING CODES":1,1:0)
 .D TERM^PXRMLDR(TNAME,.TERMARR) I $D(TERMARR("DNE")) D ERROR("Reminder Term "_TNAME_" not found",.ERROR) Q
 .I CODE'="",CODESYS'="" D
 ..S TXIEN=0 F  S TXIEN=$O(TERMARR("E","PXD(811.2,",TXIEN)) Q:TXIEN'>0  D GETCODES(TXIEN,TNAME,.TXARRAY)
 ..S RESULT=$S('$D(TXARRAY(CODE)):0_U_0,1:1_U_START)
 .I +RESULT=1 Q
 .I $G(ITEMTYPE)="" Q
 .I $G(ITEM)="" Q
 .I '$D(TERMARR("E",ITEMTYPE,ITEM)) Q
 .S RESULT=1_U_START
 Q RESULT
 ;
BLDTARR(TERMARR) ;
 S TERMARR(1)="VA-WH MAMMOGRAM SCREENING CODES",TERMARR(2)="VA-WH MAMMOGRAM BILAT DIAGNOSTIC CODES"
 S TERMARR(3)="VA-WH MAMMOGRAM UNILAT DIAGNOSTIC CODES",TERMARR(4)="VA-WH MRI OF THE BREASTS CODES"
 S TERMARR(5)="VA-WH ULTRASOUND OF THE BREAST CODES"
 Q 5
 ;
EVAL(PAT,ITEMIEN,ITEMTYPE,CODE,CODESYS,ORDIEN,PROV,DATE,LOC,ERROR) ;evaluation of a reminder
 N CNT,INPUT,MSG,START,VALUE
 S INPUT("CODE")=CODE,INPUT("CODESYS")=CODESYS,INPUT("ITEMTYPE")=ITEMTYPE,INPUT("ITEM")=ITEMIEN
 S VALUE=$$CHCKPROC(.INPUT,.ERROR)
 I +VALUE=0 Q
 S START=+$P(VALUE,U,2)
 D ADD^PXRMEOC(PAT,DATE,+ORDIEN_";OR(100,",START,0,"BREAST CARE",.MSG)
 I $D(MSG) D  Q
 .D ERROR("UPDATE^DIE Error:",.ERROR)
 .S CNT=0 F  S CNT=$O(MSG(CNT)) Q:CNT'>0  D ERROR(MSG(CNT),.ERROR)
 Q
 ;
GETTYPE(APPL) ;
 I APPL="RADIOLOGY" Q "RAMIS(71,"
 Q ""
 ;
SENDERR(ERROR) ;
 K ^TMP("PXRMXMZ",$J)
 M ^TMP("PXRMXMZ",$J)=ERROR
 D SEND^PXRMMSG("PXRMXMZ","Clinical Reminder Radiology HL7 listener.")
 K ^TMP("PXRMXMZ",$J)
 Q
 ;
VALIDCTL(APPL,CNTRL) ;
 N RESULT
 S RESULT=0
 I APPL="RADIOLOGY" D  Q RESULT
 .I CNTRL="NW" S RESULT=1 Q
 .I CNTRL="DC" S RESULT=1 Q
 Q RESULT
 ;
VALIDAPL(APPL) ;
 I APPL="RADIOLOGY" 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