RAHLRPC ;HIRMFO/BNT-Rad/NM HL7 Protocol calls ; 20 Apr 2011 4:41 PM
;;5.0;Radiology/Nuclear Medicine;**12,25,54,71,82,81,84,1003**;Nov 01, 2010;Build 3
; 03/16/2006 *71 Rem Call 124379 allow exam updates to create HL7 msg
;
;Integration Agreements
;----------------------
;$$FIND1^DIC(2051); GETS^DIQ(2056)
;all access to ^ORD(101 to maintain application specific protocols(872)
;read w/FileMan HL7 APPLICATION PARAMETER(10136)
;
REG ; register exam
;IHS/BJI/DAY - Patch 1003 - Add call to vendor's HL7 routine
K RAHLRPCZ S X="RAHLRPCZ" X ^%ZOSF("TEST") I $T D REG^RAHLRPCZ I $G(RAHLRPCZ)=1 K RAHLRPCZ Q
;End Patch
N X,RA101Z,RAEID
S RA101Z="RA REF" ; get all protocols beginning RA REG
F S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA REG" D
.S RAEID=$O(^ORD(101,"B",RA101Z,0))
.I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR
Q
CANCEL ; cancel exam
;IHS/BJI/DAY - Patch 1003 - Add call to vendor's HL7 routine
K RAHLRPCZ S X="RAHLRPCZ" X ^%ZOSF("TEST") I $T D CANCEL^RAHLRPCZ I $G(RAHLRPCZ)=1 K RAHLRPCZ Q
;End Patch
N X,RA101Z,RAEID
S RA101Z="RA CANCEK" ; get all protocols beginning RA CANCEL
F S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA CANCEL" D
.S RAEID=$O(^ORD(101,"B",RA101Z,0))
.I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR
Q
;
RPT ; report verified or released/not verified
;IHS/BJI/DAY - Patch 1003 - Add call to vendor's HL7 routine
K RAHLRPCZ S X="RAHLRPCZ" X ^%ZOSF("TEST") I $T D RPT^RAHLRPCZ I $G(RAHLRPCZ)=1 K RAHLRPCZ Q
;End Patch
N X,RA101Z,RAEID,RASSS ; RASSS subcriber array to be passed to HLL for GENERATE^HLMA
;S X="^%ET",@^%ZOSF("TRAP")
S RA101Z="RA RPS" ; get all protocols beginning RA RPT
F S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA RPT" D
.S RAEID=$O(^ORD(101,"B",RA101Z,0)) K RASSS ; RA*5*81
.S:$L($G(RANOSEND)) RAEID=$$GETEID(RAEID,RANOSEND,.RASSS) ;RA*5*81
.I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLRPT
K RANOSEND
Q
;
EXM ;Examined case; called from RAUTL1 and RASTED after a case has been edited.
;IHS/BJI/DAY - Patch 1003 - Add call to vendor's HL7 routine
K RAHLRPCZ S X="RAHLRPCZ" X ^%ZOSF("TEST") I $T D EXM^RAHLRPCZ I $G(RAHLRPCZ)=1 K RAHLRPCZ Q
;End Patch
;
;Called from RAUTL1 and RASTED after a case's status is upgraded
; and case's 30th piece is null
;
;If this new status is :
; at a status (or higher than a status) where
; GENERATE EXAMINED HL7 MSG = Y,
; then :
; 1. send an HL7 msg re this case having reached EXAMINED status
; 2. set subfile 70.03's HL7 EXAMINED MSG SENT to Y
;
; RALOWER = next lower status
; RANEWST = new status ien
; RAEXEDT = Indication of editing of: proc, proc mod, req phys, CPT mod, Tech comm...
; RAGENHL7 = Indication that sending ORU is due...
; RASSSX1(IENs) = Array of subscribers from 771, the message will be sent (SCIMGE)
;
N RAIMGTYI,RAIMGTYJ,RALOWER,RANEWST,RAEXMDUN,RAGENHL7,RASSSX1
S RAIMGTYI=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2),RAIMGTYJ=$P(^RA(79.2,RAIMGTYI,0),U),RANEWST=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3)
S:$P(^RA(72,RANEWST,0),U,8)="Y" RAGENHL7=1 ;this status has GEN HL7 marked Y
; look thru lower statuses for GEN HL7 marked Y
DOWN S RALOWER=$P($G(^RA(72,+RANEWST,0)),U,3)
I '$G(RAGENHL7) F S RALOWER=$O(^RA(72,"AA",RAIMGTYJ,RALOWER),-1) Q:RALOWER<1 S:$P(^RA(72,+$O(^RA(72,"AA",RAIMGTYJ,RALOWER,0)),0),U,8)="Y" RAGENHL7=1
;?? none of the lower status levels have GEN HL7 marked Y
K:$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,30)="Y" RAGENHL7 ;already sent
;Q:'$G(RAEXEDT)&'$G(RAGENHL7)
; Business Rule: RA*5*84 sends an examined message to ScImage unconditionally
I '$G(RAEXEDT),'$G(RAGENHL7) Q:'$O(^RA(79.7,0)) D Q:'$O(RASSSX1(0))
.N X,RASSS,RASSSL S X=0 F S X=$O(^RA(79.7,X)) Q:'X S:$P(^(X,0),U,2) RASSS(X)=""
.D:$D(RASSS) GETSUB^RAHLRS1(.RASSS,.RASSSX1,.RASSSL)
1 N RAEXMDUN
S RAEXMDUN=1
A1 N X,RA101Z,RAEID
S RA101Z="RA EXAMINEC" ; get all protocols beginning RA EXAMINED
F S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA EXAMINED" D
.N RAGENHL7 S RAEID=$O(^ORD(101,"B",RA101Z,0))
.I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR
S:$G(RAGENHL7) $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,30)="Y"
Q
;
GETEID(RAEID,RANOSEND,RASSS) ; RA*5*81 Return RAEID or 0 (zero) = for future use.
; RAEID = IEN of regular Event driver
; RANOSEND Application name or IEN from 771 file.. don't send message to Subcr. with this application.
; RASSS Array of subcribers (IENs) associated with RANOSEND application
; 0 (zero) returned if No subscriber exist or all subscribers associated with RANOSEND application.
S RAEID=$G(RAEID) Q:'RAEID!'$L($G(RANOSEND))!'$D(^ORD(101,+RAEID,0)) RAEID
N RAXX,ERR,X1,Y1,YY,RAPL,RANEW,RAPIDS,RAIEDS,DIERR,RAERR
S RAPL=$S(+RANOSEND:+RANOSEND,1:$$FIND1^DIC(771,"","X",RANOSEND,"","","RAERR"))
Q:'RAPL!($D(RAERR)#2) RAEID
D GETS^DIQ(101,RAEID_",","**","I","RAXX","ERR")
Q:$D(ERR) RAEID ; Was not able get Event driver info... so just pass event driver...
Q:'$D(RAXX(101.0775)) 0 ;No subcribers exist for Event driver
S X1="",RANEW=0,Y1=0 F S X1=$O(RAXX(101.0775,X1)) Q:'$L(X1) D
.S YY=$G(RAXX(101.0775,X1,.01,"I"))
.I $P($G(^ORD(101,+YY,770)),U,2)=RAPL D Q
..S Y1=Y1+1,RASSS("EXCLUDE SUBSCRIBER",Y1)=YY ;Y1= 1,2,3...
.S RANEW=1
Q:'RANEW 0 ;All subscribers are associated with application RANOSEND.. Don't send the message.
Q RAEID
RAHLRPC ;HIRMFO/BNT-Rad/NM HL7 Protocol calls ; 20 Apr 2011 4:41 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**12,25,54,71,82,81,84,1003**;Nov 01, 2010;Build 3
+2 ; 03/16/2006 *71 Rem Call 124379 allow exam updates to create HL7 msg
+3 ;
+4 ;Integration Agreements
+5 ;----------------------
+6 ;$$FIND1^DIC(2051); GETS^DIQ(2056)
+7 ;all access to ^ORD(101 to maintain application specific protocols(872)
+8 ;read w/FileMan HL7 APPLICATION PARAMETER(10136)
+9 ;
REG ; register exam
+1 ;IHS/BJI/DAY - Patch 1003 - Add call to vendor's HL7 routine
+2 KILL RAHLRPCZ
SET X="RAHLRPCZ"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO REG^RAHLRPCZ
IF $GET(RAHLRPCZ)=1
KILL RAHLRPCZ
QUIT
+3 ;End Patch
+4 NEW X,RA101Z,RAEID
+5 ; get all protocols beginning RA REG
SET RA101Z="RA REF"
+6 FOR
SET RA101Z=$ORDER(^ORD(101,"B",RA101Z))
IF RA101Z'["RA REG"
QUIT
Begin DoDot:1
+7 SET RAEID=$ORDER(^ORD(101,"B",RA101Z,0))
+8 IF RAEID
IF '$LENGTH($PIECE(^ORD(101,RAEID,0),"^",3))
DO EN^RAHLR
End DoDot:1
+9 QUIT
CANCEL ; cancel exam
+1 ;IHS/BJI/DAY - Patch 1003 - Add call to vendor's HL7 routine
+2 KILL RAHLRPCZ
SET X="RAHLRPCZ"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO CANCEL^RAHLRPCZ
IF $GET(RAHLRPCZ)=1
KILL RAHLRPCZ
QUIT
+3 ;End Patch
+4 NEW X,RA101Z,RAEID
+5 ; get all protocols beginning RA CANCEL
SET RA101Z="RA CANCEK"
+6 FOR
SET RA101Z=$ORDER(^ORD(101,"B",RA101Z))
IF RA101Z'["RA CANCEL"
QUIT
Begin DoDot:1
+7 SET RAEID=$ORDER(^ORD(101,"B",RA101Z,0))
+8 IF RAEID
IF '$LENGTH($PIECE(^ORD(101,RAEID,0),"^",3))
DO EN^RAHLR
End DoDot:1
+9 QUIT
+10 ;
RPT ; report verified or released/not verified
+1 ;IHS/BJI/DAY - Patch 1003 - Add call to vendor's HL7 routine
+2 KILL RAHLRPCZ
SET X="RAHLRPCZ"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO RPT^RAHLRPCZ
IF $GET(RAHLRPCZ)=1
KILL RAHLRPCZ
QUIT
+3 ;End Patch
+4 ; RASSS subcriber array to be passed to HLL for GENERATE^HLMA
NEW X,RA101Z,RAEID,RASSS
+5 ;S X="^%ET",@^%ZOSF("TRAP")
+6 ; get all protocols beginning RA RPT
SET RA101Z="RA RPS"
+7 FOR
SET RA101Z=$ORDER(^ORD(101,"B",RA101Z))
IF RA101Z'["RA RPT"
QUIT
Begin DoDot:1
+8 ; RA*5*81
SET RAEID=$ORDER(^ORD(101,"B",RA101Z,0))
KILL RASSS
+9 ;RA*5*81
IF $LENGTH($GET(RANOSEND))
SET RAEID=$$GETEID(RAEID,RANOSEND,.RASSS)
+10 IF RAEID
IF '$LENGTH($PIECE(^ORD(101,RAEID,0),"^",3))
DO EN^RAHLRPT
End DoDot:1
+11 KILL RANOSEND
+12 QUIT
+13 ;
EXM ;Examined case; called from RAUTL1 and RASTED after a case has been edited.
+1 ;IHS/BJI/DAY - Patch 1003 - Add call to vendor's HL7 routine
+2 KILL RAHLRPCZ
SET X="RAHLRPCZ"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO EXM^RAHLRPCZ
IF $GET(RAHLRPCZ)=1
KILL RAHLRPCZ
QUIT
+3 ;End Patch
+4 ;
+5 ;Called from RAUTL1 and RASTED after a case's status is upgraded
+6 ; and case's 30th piece is null
+7 ;
+8 ;If this new status is :
+9 ; at a status (or higher than a status) where
+10 ; GENERATE EXAMINED HL7 MSG = Y,
+11 ; then :
+12 ; 1. send an HL7 msg re this case having reached EXAMINED status
+13 ; 2. set subfile 70.03's HL7 EXAMINED MSG SENT to Y
+14 ;
+15 ; RALOWER = next lower status
+16 ; RANEWST = new status ien
+17 ; RAEXEDT = Indication of editing of: proc, proc mod, req phys, CPT mod, Tech comm...
+18 ; RAGENHL7 = Indication that sending ORU is due...
+19 ; RASSSX1(IENs) = Array of subscribers from 771, the message will be sent (SCIMGE)
+20 ;
+21 NEW RAIMGTYI,RAIMGTYJ,RALOWER,RANEWST,RAEXMDUN,RAGENHL7,RASSSX1
+22 SET RAIMGTYI=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),U,2)
SET RAIMGTYJ=$PIECE(^RA(79.2,RAIMGTYI,0),U)
SET RANEWST=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3)
+23 ;this status has GEN HL7 marked Y
IF $PIECE(^RA(72,RANEWST,0),U,8)="Y"
SET RAGENHL7=1
+24 ; look thru lower statuses for GEN HL7 marked Y
DOWN SET RALOWER=$PIECE($GET(^RA(72,+RANEWST,0)),U,3)
+1 IF '$GET(RAGENHL7)
FOR
SET RALOWER=$ORDER(^RA(72,"AA",RAIMGTYJ,RALOWER),-1)
IF RALOWER<1
QUIT
IF $PIECE(^RA(72,+$ORDER(^RA(72,"AA",RAIMGTYJ,RALOWER,0)),0),U,8)="Y"
SET RAGENHL7=1
+2 ;?? none of the lower status levels have GEN HL7 marked Y
+3 ;already sent
IF $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,30)="Y"
KILL RAGENHL7
+4 ;Q:'$G(RAEXEDT)&'$G(RAGENHL7)
+5 ; Business Rule: RA*5*84 sends an examined message to ScImage unconditionally
+6 IF '$GET(RAEXEDT)
IF '$GET(RAGENHL7)
IF '$ORDER(^RA(79.7,0))
QUIT
Begin DoDot:1
+7 NEW X,RASSS,RASSSL
SET X=0
FOR
SET X=$ORDER(^RA(79.7,X))
IF 'X
QUIT
IF $PIECE(^(X,0),U,2)
SET RASSS(X)=""
+8 IF $DATA(RASSS)
DO GETSUB^RAHLRS1(.RASSS,.RASSSX1,.RASSSL)
End DoDot:1
IF '$ORDER(RASSSX1(0))
QUIT
1 NEW RAEXMDUN
+1 SET RAEXMDUN=1
A1 NEW X,RA101Z,RAEID
+1 ; get all protocols beginning RA EXAMINED
SET RA101Z="RA EXAMINEC"
+2 FOR
SET RA101Z=$ORDER(^ORD(101,"B",RA101Z))
IF RA101Z'["RA EXAMINED"
QUIT
Begin DoDot:1
+3 NEW RAGENHL7
SET RAEID=$ORDER(^ORD(101,"B",RA101Z,0))
+4 IF RAEID
IF '$LENGTH($PIECE(^ORD(101,RAEID,0),"^",3))
DO EN^RAHLR
End DoDot:1
+5 IF $GET(RAGENHL7)
SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,30)="Y"
+6 QUIT
+7 ;
GETEID(RAEID,RANOSEND,RASSS) ; RA*5*81 Return RAEID or 0 (zero) = for future use.
+1 ; RAEID = IEN of regular Event driver
+2 ; RANOSEND Application name or IEN from 771 file.. don't send message to Subcr. with this application.
+3 ; RASSS Array of subcribers (IENs) associated with RANOSEND application
+4 ; 0 (zero) returned if No subscriber exist or all subscribers associated with RANOSEND application.
+5 SET RAEID=$GET(RAEID)
IF 'RAEID!'$LENGTH($GET(RANOSEND))!'$DATA(^ORD(101,+RAEID,0))
QUIT RAEID
+6 NEW RAXX,ERR,X1,Y1,YY,RAPL,RANEW,RAPIDS,RAIEDS,DIERR,RAERR
+7 SET RAPL=$SELECT(+RANOSEND:+RANOSEND,1:$$FIND1^DIC(771,"","X",RANOSEND,"","","RAERR"))
+8 IF 'RAPL!($DATA(RAERR)#2)
QUIT RAEID
+9 DO GETS^DIQ(101,RAEID_",","**","I","RAXX","ERR")
+10 ; Was not able get Event driver info... so just pass event driver...
IF $DATA(ERR)
QUIT RAEID
+11 ;No subcribers exist for Event driver
IF '$DATA(RAXX(101.0775))
QUIT 0
+12 SET X1=""
SET RANEW=0
SET Y1=0
FOR
SET X1=$ORDER(RAXX(101.0775,X1))
IF '$LENGTH(X1)
QUIT
Begin DoDot:1
+13 SET YY=$GET(RAXX(101.0775,X1,.01,"I"))
+14 IF $PIECE($GET(^ORD(101,+YY,770)),U,2)=RAPL
Begin DoDot:2
+15 ;Y1= 1,2,3...
SET Y1=Y1+1
SET RASSS("EXCLUDE SUBSCRIBER",Y1)=YY
End DoDot:2
QUIT
+16 SET RANEW=1
End DoDot:1
+17 ;All subscribers are associated with application RANOSEND.. Don't send the message.
IF 'RANEW
QUIT 0
+18 QUIT RAEID
