- RAHLRPC ;HIRMFO/BNT-Rad/NM HL7 Protocol calls ;12 Jan 2018 7:43 AM
- ;;5.0;Radiology/Nuclear Medicine;**12,25,54,71,82,81,84,144**;Mar 16, 1998;Build 1
- ; 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
- 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
- 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
- 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
- ;
- RELEASE ;v2.4 only - Release Study (VAQ) -KLM/p144
- N X,RA101Z,RAEID,RAVAQ
- S RAVAQ="" ;flg
- S RA101Z="RA RELEASD" ;get protocol for RA RELEASE
- F S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA RELEASE" D
- .S RAEID=$O(^ORD(101,"B",RA101Z,0))
- .S:$L($G(RANOSEND)) RAEID=$$GETEID(RAEID,RANOSEND,.RASSS)
- .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.
- ;
- ;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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLRPC 5129 printed Jan 18, 2025@03:36:30 Page 2
- 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
- +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 NEW X,RA101Z,RAEID
- +2 ; get all protocols beginning RA REG
- SET RA101Z="RA REF"
- +3 FOR
- SET RA101Z=$ORDER(^ORD(101,"B",RA101Z))
- if RA101Z'["RA REG"
- QUIT
- Begin DoDot:1
- +4 SET RAEID=$ORDER(^ORD(101,"B",RA101Z,0))
- +5 IF RAEID
- IF '$LENGTH($PIECE(^ORD(101,RAEID,0),"^",3))
- DO EN^RAHLR
- End DoDot:1
- +6 QUIT
- CANCEL ; cancel exam
- +1 NEW X,RA101Z,RAEID
- +2 ; get all protocols beginning RA CANCEL
- SET RA101Z="RA CANCEK"
- +3 FOR
- SET RA101Z=$ORDER(^ORD(101,"B",RA101Z))
- if RA101Z'["RA CANCEL"
- QUIT
- Begin DoDot:1
- +4 SET RAEID=$ORDER(^ORD(101,"B",RA101Z,0))
- +5 IF RAEID
- IF '$LENGTH($PIECE(^ORD(101,RAEID,0),"^",3))
- DO EN^RAHLR
- End DoDot:1
- +6 QUIT
- +7 ;
- RPT ; report verified or released/not verified
- +1 ; RASSS subcriber array to be passed to HLL for GENERATE^HLMA
- NEW X,RA101Z,RAEID,RASSS
- +2 ;S X="^%ET",@^%ZOSF("TRAP")
- +3 ; get all protocols beginning RA RPT
- SET RA101Z="RA RPS"
- +4 FOR
- SET RA101Z=$ORDER(^ORD(101,"B",RA101Z))
- if RA101Z'["RA RPT"
- QUIT
- Begin DoDot:1
- +5 ; RA*5*81
- SET RAEID=$ORDER(^ORD(101,"B",RA101Z,0))
- KILL RASSS
- +6 ;RA*5*81
- if $LENGTH($GET(RANOSEND))
- SET RAEID=$$GETEID(RAEID,RANOSEND,.RASSS)
- +7 IF RAEID
- IF '$LENGTH($PIECE(^ORD(101,RAEID,0),"^",3))
- DO EN^RAHLRPT
- End DoDot:1
- +8 KILL RANOSEND
- +9 QUIT
- +10 ;
- RELEASE ;v2.4 only - Release Study (VAQ) -KLM/p144
- +1 NEW X,RA101Z,RAEID,RAVAQ
- +2 ;flg
- SET RAVAQ=""
- +3 ;get protocol for RA RELEASE
- SET RA101Z="RA RELEASD"
- +4 FOR
- SET RA101Z=$ORDER(^ORD(101,"B",RA101Z))
- if RA101Z'["RA RELEASE"
- QUIT
- Begin DoDot:1
- +5 SET RAEID=$ORDER(^ORD(101,"B",RA101Z,0))
- +6 if $LENGTH($GET(RANOSEND))
- SET RAEID=$$GETEID(RAEID,RANOSEND,.RASSS)
- +7 IF RAEID
- IF '$LENGTH($PIECE(^ORD(101,RAEID,0),"^",3))
- DO EN^RAHLRPT
- End DoDot:1
- +8 KILL RANOSEND
- +9 QUIT
- +10 ;
- EXM ;Examined case; called from RAUTL1 and RASTED after a case has been edited.
- +1 ;
- +2 ;Called from RAUTL1 and RASTED after a case's status is upgraded
- +3 ; and case's 30th piece is null
- +4 ;
- +5 ;If this new status is :
- +6 ; at a status (or higher than a status) where
- +7 ; GENERATE EXAMINED HL7 MSG = Y,
- +8 ; then :
- +9 ; 1. send an HL7 msg re this case having reached EXAMINED status
- +10 ; 2. set subfile 70.03's HL7 EXAMINED MSG SENT to Y
- +11 ;
- +12 ; RALOWER = next lower status
- +13 ; RANEWST = new status ien
- +14 ; RAEXEDT = Indication of editing of: proc, proc mod, req phys, CPT mod, Tech comm...
- +15 ; RAGENHL7 = Indication that sending ORU is due...
- +16 ; RASSSX1(IENs) = Array of subscribers from 771, the message will be sent (SCIMGE)
- +17 ;
- +18 NEW RAIMGTYI,RAIMGTYJ,RALOWER,RANEWST,RAEXMDUN,RAGENHL7,RASSSX1
- +19 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)
- +20 ;this status has GEN HL7 marked Y
- if $PIECE(^RA(72,RANEWST,0),U,8)="Y"
- SET RAGENHL7=1
- +21 ; 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