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

RAHLRPC.m

Go to the documentation of this file.
  1. RAHLRPC ;HIRMFO/BNT-Rad/NM HL7 Protocol calls ;12 Jan 2018 7:43 AM
  1. ;;5.0;Radiology/Nuclear Medicine;**12,25,54,71,82,81,84,144**;Mar 16, 1998;Build 1
  1. ; 03/16/2006 *71 Rem Call 124379 allow exam updates to create HL7 msg
  1. ;
  1. ;Integration Agreements
  1. ;----------------------
  1. ;$$FIND1^DIC(2051); GETS^DIQ(2056)
  1. ;all access to ^ORD(101 to maintain application specific protocols(872)
  1. ;read w/FileMan HL7 APPLICATION PARAMETER(10136)
  1. ;
  1. REG ; register exam
  1. N X,RA101Z,RAEID
  1. S RA101Z="RA REF" ; get all protocols beginning RA REG
  1. F S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA REG" D
  1. .S RAEID=$O(^ORD(101,"B",RA101Z,0))
  1. .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR
  1. Q
  1. CANCEL ; cancel exam
  1. N X,RA101Z,RAEID
  1. S RA101Z="RA CANCEK" ; get all protocols beginning RA CANCEL
  1. F S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA CANCEL" D
  1. .S RAEID=$O(^ORD(101,"B",RA101Z,0))
  1. .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR
  1. Q
  1. ;
  1. RPT ; report verified or released/not verified
  1. N X,RA101Z,RAEID,RASSS ; RASSS subcriber array to be passed to HLL for GENERATE^HLMA
  1. ;S X="^%ET",@^%ZOSF("TRAP")
  1. S RA101Z="RA RPS" ; get all protocols beginning RA RPT
  1. F S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA RPT" D
  1. .S RAEID=$O(^ORD(101,"B",RA101Z,0)) K RASSS ; RA*5*81
  1. .S:$L($G(RANOSEND)) RAEID=$$GETEID(RAEID,RANOSEND,.RASSS) ;RA*5*81
  1. .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLRPT
  1. K RANOSEND
  1. Q
  1. ;
  1. RELEASE ;v2.4 only - Release Study (VAQ) -KLM/p144
  1. N X,RA101Z,RAEID,RAVAQ
  1. S RAVAQ="" ;flg
  1. S RA101Z="RA RELEASD" ;get protocol for RA RELEASE
  1. F S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA RELEASE" D
  1. .S RAEID=$O(^ORD(101,"B",RA101Z,0))
  1. .S:$L($G(RANOSEND)) RAEID=$$GETEID(RAEID,RANOSEND,.RASSS)
  1. .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLRPT
  1. K RANOSEND
  1. Q
  1. ;
  1. EXM ;Examined case; called from RAUTL1 and RASTED after a case has been edited.
  1. ;
  1. ;Called from RAUTL1 and RASTED after a case's status is upgraded
  1. ; and case's 30th piece is null
  1. ;
  1. ;If this new status is :
  1. ; at a status (or higher than a status) where
  1. ; GENERATE EXAMINED HL7 MSG = Y,
  1. ; then :
  1. ; 1. send an HL7 msg re this case having reached EXAMINED status
  1. ; 2. set subfile 70.03's HL7 EXAMINED MSG SENT to Y
  1. ;
  1. ; RALOWER = next lower status
  1. ; RANEWST = new status ien
  1. ; RAEXEDT = Indication of editing of: proc, proc mod, req phys, CPT mod, Tech comm...
  1. ; RAGENHL7 = Indication that sending ORU is due...
  1. ; RASSSX1(IENs) = Array of subscribers from 771, the message will be sent (SCIMGE)
  1. ;
  1. N RAIMGTYI,RAIMGTYJ,RALOWER,RANEWST,RAEXMDUN,RAGENHL7,RASSSX1
  1. 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)
  1. S:$P(^RA(72,RANEWST,0),U,8)="Y" RAGENHL7=1 ;this status has GEN HL7 marked Y
  1. ; look thru lower statuses for GEN HL7 marked Y
  1. DOWN S RALOWER=$P($G(^RA(72,+RANEWST,0)),U,3)
  1. 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
  1. ;?? none of the lower status levels have GEN HL7 marked Y
  1. K:$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,30)="Y" RAGENHL7 ;already sent
  1. ;Q:'$G(RAEXEDT)&'$G(RAGENHL7)
  1. ; Business Rule: RA*5*84 sends an examined message to ScImage unconditionally
  1. I '$G(RAEXEDT),'$G(RAGENHL7) Q:'$O(^RA(79.7,0)) D Q:'$O(RASSSX1(0))
  1. .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)=""
  1. .D:$D(RASSS) GETSUB^RAHLRS1(.RASSS,.RASSSX1,.RASSSL)
  1. 1 N RAEXMDUN
  1. S RAEXMDUN=1
  1. A1 N X,RA101Z,RAEID
  1. S RA101Z="RA EXAMINEC" ; get all protocols beginning RA EXAMINED
  1. F S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA EXAMINED" D
  1. .N RAGENHL7 S RAEID=$O(^ORD(101,"B",RA101Z,0))
  1. .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR
  1. S:$G(RAGENHL7) $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,30)="Y"
  1. Q
  1. ;
  1. GETEID(RAEID,RANOSEND,RASSS) ; RA*5*81 Return RAEID or 0 (zero) = for future use.
  1. ; RAEID = IEN of regular Event driver
  1. ; RANOSEND Application name or IEN from 771 file.. don't send message to Subcr. with this application.
  1. ; RASSS Array of subcribers (IENs) associated with RANOSEND application
  1. ; 0 (zero) returned if No subscriber exist or all subscribers associated with RANOSEND application.
  1. S RAEID=$G(RAEID) Q:'RAEID!'$L($G(RANOSEND))!'$D(^ORD(101,+RAEID,0)) RAEID
  1. N RAXX,ERR,X1,Y1,YY,RAPL,RANEW,RAPIDS,RAIEDS,DIERR,RAERR
  1. S RAPL=$S(+RANOSEND:+RANOSEND,1:$$FIND1^DIC(771,"","X",RANOSEND,"","","RAERR"))
  1. Q:'RAPL!($D(RAERR)#2) RAEID
  1. D GETS^DIQ(101,RAEID_",","**","I","RAXX","ERR")
  1. Q:$D(ERR) RAEID ; Was not able get Event driver info... so just pass event driver...
  1. Q:'$D(RAXX(101.0775)) 0 ;No subcribers exist for Event driver
  1. S X1="",RANEW=0,Y1=0 F S X1=$O(RAXX(101.0775,X1)) Q:'$L(X1) D
  1. .S YY=$G(RAXX(101.0775,X1,.01,"I"))
  1. .I $P($G(^ORD(101,+YY,770)),U,2)=RAPL D Q
  1. ..S Y1=Y1+1,RASSS("EXCLUDE SUBSCRIBER",Y1)=YY ;Y1= 1,2,3...
  1. .S RANEW=1
  1. Q:'RANEW 0 ;All subscribers are associated with application RANOSEND.. Don't send the message.
  1. Q RAEID