RAO7XX ;HISC/SS-Sending XX HL7 message to CPRS ;11/19/01 09:07
;;5.0;Radiology/Nuclear Medicine;**18,26,28,32,82**;Mar 16, 1998;Build 8
;Check if requested and registered procedures differ in:
; proc, requesting physician, proc mod(s)
;if there are changes - send XX message and return 1, otherwise 0
; called from RAREG2
EN1(RAOIFN1) ;P18 entry point for "Register exams" and "Add to last visit" options
K RAREGMOD
Q:'$D(^RAO(75.1,RAOIFN1,0)) 0
Q:'$D(^RAMIS(71,$P(^RAO(75.1,RAOIFN1,0),"^",2),0)) 0
N RAPRTYPE S RAPRTYPE=$P(^RAMIS(71,$P(^RAO(75.1,RAOIFN1,0),"^",2),0),"^",6)
Q:RAPRTYPE="P" 0 ;quit processing if parent proc, since RAREG2 treats an order, not each descendent of an order, thus no "XX" and no Alert
I $$ISCHNGD(RAOIFN1,1)=0 Q 0 ;no changes or no OR*3*92
CHCK N RAREGMOD S RAREGMOD="R" ;as a flag for registering mode
I $$ORVR^RAORDU()'<3 D EN1^RAO7NEW(RAOIFN1) ;sends HL7 message
Q 1 ;proc/reqphys/pmod was changed
;
;Can be used only for EXAMS that DO NOT contain Parent procedures
;ISSCHNGD Checks: Was original procedure changed?
;if proc/prc mod/rqstr changed, return 1 to syncrhonize with CPRS
;Usage: RAIEN751 recNo in 75.1 (like RAOIFN)
;if SNDALERT=1 sends alert to provider requested the order
;----------------
ISCHNGD(RAIEN751,SNDALERT) ;P18
N RACHANGE,RAX751,RAX70,RASTRING
N RAD751 S RAD751=$G(^RAO(75.1,RAIEN751,0),-1),RASTRING=""
Q:RAD751=-1 0
N RAPAT S RAPAT=$P(RAD751,"^",1)
N RAD70 S RAD70=$$FNDIN70(RAPAT,RAIEN751,"V")
N RAD70SB S RAD70SB=$$FNDIN70(RAPAT,RAIEN751,"T")
Q:RAD70=0 0
N RAPR751 S RAPR751=$P(RAD751,"^",2) ;ien proc from order
N RAPHYSID S RAPHYSID=$P(RAD751,"^",14) ;ien req phys
S RAPR70=$P(RAD70,"^",2) ;ien proc from exam
S RACHANGE=0
I RAPR751'=RAPR70,(RAPRTYPE'="P") S RACHANGE=1,$P(RASTRING,"/",4,5)=RAPR751_"/"_RAPR70 ; nonparent,proc changed
I RAPR751=RAPR70,(RAPRTYPE'="P") S $P(RASTRING,"/",4)=RAPR751 ;save unchanged proc name
I RAPHYSID'=$P(RAD70,"^",14) S RACHANGE=1,$P(RASTRING,"/",6,7)=RAPHYSID_"/"_$P(RAD70,"^",14) ;req phy changed
D STR751^RAUTL10(.RAX751,RAIEN751)
D STR70^RAUTL10(.RAX70,RAPAT,$P(RAD70SB,"^"),$P(RAD70SB,"^",2))
I RAX751'=RAX70 S RACHANGE=1,$P(RASTRING,"/",8,9)=RAX751_"/"_RAX70 ;proc mods changed
Q:'RACHANGE 0
S $P(RASTRING,"/",1,3)=RAPAT_"/"_$P(RAD70SB,"^")_"/"_$P(RAD70SB,"^",2) ;dfn,invdt,case ien
S:$P(RASTRING,"/",6)="" $P(RASTRING,"/",6)=RAPHYSID ;recipient of msg
I $G(SNDALERT,0)=1 D
. I $$PATCH^XPDUTL("OR*3.0*112") D SETNOTIF^RAO7PC4(RAIEN751) Q
. D SETALERT^RAO7PC4
B1P18 Q:'$$PATCH^XPDUTL("OR*3.0*92") 0 ;CPRS patch not installed yet-return zero (do not send XX message).Alert has been sent above,because it should be sent anyway
Q 1 ;one or more changes from orig order AND OR*3*92
;
;RAPT like RADFN
;RADT like RADTI
;RACSN like RACN
;If RARET="V" returns string value, otherwise - $Q of the node
;if failure returns "0"
FNDIN70M(RAPT,RADT,RACSN,RARET) ;P18
N RALV,RALFL
S (RALV,RALFL)=0
N RALVAR2,RAVAL2
S RALV=$O(^RADPT(RAPT,"DT",RADT,"P","B",RACSN,0))
Q:+RALV=0 0
Q:RARET="V" $G(^RADPT(RAPT,"DT",RADT,"P",RALV,0),0)
Q:RARET="T" RADT_"^"_RALV
Q $Q(^RADPT(RAPT,"DT",RADT,"P",RALV))
;
;search for #70 entry using PATIEN and Order No from 75.1
;works correctly ONLY FOR ORDERS that do NOT contain PARENT PROCEDURE
;RETRN="V" returns value
;RETRN="T" returns D1^D2 of #70
;otherwise - $Q
FNDIN70(RAPATN,RAORDN,RETRN) ;
N RA18A,RA18B
S RA18A=$O(^RADPT("AO",RAORDN,RAPATN,0))
Q:RA18A="" 0
S RA18B=$O(^RADPT("AO",RAORDN,RAPATN,RA18A,0))
Q:RA18B="" 0
Q:RETRN="V" $G(^RADPT(RAPATN,"DT",RA18A,"P",RA18B,0),0)
Q:RETRN="T" RA18A_"^"_RA18B
Q $Q(^RADPT(RAPATN,"DT",RA18A,"P",RA18B))
Q
;
;
UPDTRA0 ;P18 updates var RAO with data from file #70 and sets RAD70SB variable (D2^D3 of #70), called from RAO7NEW
N RAD70
S RAD70=0
;if registering mode (should not be parent procedure, so we can locate the exam in #70 by OrderN) - data and D2^D3 in #70 for the Order No
S:RAREGMOD="R" RAD70=$$FNDIN70(+RA0,RAOIFN,"V"),RAD70SB=$$FNDIN70(+RA0,RAOIFN,"T")
;editing exam had called SVBEFOR, and thus RAPRIEN()s are defined
S:RAREGMOD="E" RAD70=$G(^RADPT(RAPRIEN(1),"DT",RAPRIEN(2),"P",RAPRIEN(3),0)),RAD70SB=RAPRIEN(2)_"^"_RAPRIEN(3) S:+RAD70SB=0 RAD70SB=0 S:+RAD70=0 RAD70=0 ;041801 convert null to 0
; updating info
I RAD70=0 S $P(RA0,"^",26)="" G ORCSET ; nature of new order activity
S:$P(^RAMIS(71,+$P(RA0,"^",2),0),"^",6)'="P" $P(RA0,"^",2)=$P(RAD70,"^",2) ;OBR(4) reset prc only if not parent typ
S $P(RA0,"^",9)=$P(RAD70,"^",9) ;Contract/Sharing Source
S $P(RA0,"^",14)=$P(RAD70,"^",14) ; req phys ORC(12)
ORCSET S $P(RA0,"^",15)=DUZ ;ORC(10)
Q
;
MODIF70(RA18D1,RA18D2) ;P18 uses data of Modifiers from #70 for OBR(18)
I $O(^RADPT(+RA0,"DT",RA18D1,"P",RA18D2,"M",0)) D
. S (A,RAXIT)=0
. F S A=$O(^RADPT(+RA0,"DT",RA18D1,"P",RA18D2,"M",A)) Q:A'>0 D Q:RAXIT
.. S B(0)=$G(^RADPT(+RA0,"DT",RA18D1,"P",RA18D2,"M",A,0))
.. S B(1)=$P($G(^RAMIS(71.2,+B(0),0)),U)
.. I $L(RA("OBR",18))+$L(B(1))>60 S RAXIT=1 Q
.. S RA("OBR",18)=$G(RA("OBR",18))_B(1)_RAECH(2)
.. Q
. S RA("OBR",18)=$P(RA("OBR",18),RAECH(2),1,$L(RA("OBR",18),RAECH(2))-1)
. Q
Q
SVBEFOR(RAPATN,RAINVDT,RACIEN) ;P18;send radfn,radti,racni (instead of racn and new sequencing of params
D SVBEFOR^RAO7UTL(RAPATN,RAINVDT,RACIEN) Q
;Compare proc ien after editing
CMPAFTR(SNDALERT) ;P18
K RAREGMOD
I $D(I) N I
I $D(J) N J
I $D(Y) N Y
Q:'$D(RAPRIEN) 0 ;RAPRIEN must be defined by calling SVBEFOR
N RADATA,RACHANGE,RAX,RA0,RA1,RA2,RA3,RASTRING,RAPRTYPE
S RASTRING=""
S RACHANGE=0 ;=1 if changed any of : proc, proc mod, req phys
S RADATA=$G(^RADPT(RAPRIEN(1),"DT",RAPRIEN(2),"P",RAPRIEN(3),0))
I RADATA="" G CMPEXIT
I $P(RADATA,"^",11)="" G CMPEXIT ;can't process unknown proc type
S RAPRTYPE=$P($G(^RAMIS(71,+$P($G(^RAO(75.1,+$P(RADATA,"^",11),0)),"^",2),0)),"^",6)
I RAPRTYPE="P" G CMPEXIT ; if parent-type, skip both "XX" and Alert
; compare procedure if it's nonparent
I $P(RADATA,"^",11),RAPRTYPE'="P",$P(RADATA,"^",2)'=RAPRIEN S RACHANGE=1,$P(RASTRING,"/",4,5)=RAPRIEN_"/"_$P(RADATA,"^",2) ;nonparent proc--changed
I $P(RADATA,"^",11),RAPRTYPE'="P",$P(RADATA,"^",2)=RAPRIEN S $P(RASTRING,"/",4)=RAPRIEN ;save unchanged proc name
; compare req phys
I $P(RADATA,"^",14)'=RAPRIEN(4) S RACHANGE=1,$P(RASTRING,"/",6,7)=RAPRIEN(4)_"/"_$P(RADATA,"^",14) ;req phy--changed
; compare proc mods
D STR70^RAUTL10(.RAX,RAPRIEN(1),RAPRIEN(2),RAPRIEN(3))
I RAPRIEN(5)'=RAX S RACHANGE=1,$P(RASTRING,"/",8,9)=RAPRIEN(5)_"/"_RAX ;proc mods-- changed
I 'RACHANGE G CMPEXIT
S $P(RASTRING,"/",1,3)=RAPRIEN(1)_"/"_RAPRIEN(2)_"/"_RAPRIEN(3)
S:$P(RASTRING,"/",6)="" $P(RASTRING,"/",6)=RAPRIEN(4)
; set up of vars for call to XQALERT or to ORB3
I $G(SNDALERT,0)=1 D
. I $$PATCH^XPDUTL("OR*3.0*112") D SETNOTIF^RAO7PC4($P(RADATA,"^",11)) Q
. D SETALERT^RAO7PC4
B2P18 G:'$$PATCH^XPDUTL("OR*3.0*92") CMPEXIT
;if CPRS patch not installed-don't send any XX message.Checkpoint for all modes except registration,for registration mode see ISCHNGD.Alert has been sent above,because it should be sent anyway
N RAREGMOD S RAREGMOD="E" ;edit mode
I $$ORVR^RAORDU()'<3 D EN1^RAO7NEW($P(RADATA,"^",11))
CMPEXIT ;
;Next lines are for RA*5*82
G:$G(RACHANGE) QQQ ;If proc, proc mod, req phys changed quit 1
S RAX=0 ;Quit 1 if CPT modifier changed or Tech comments changed
F S RAX=$O(^RADPT(RAPRIEN(1),"DT",RAPRIEN(2),"P",RAPRIEN(3),"CMOD",RAX)) Q:'RAX I $G(RAPRIEN("CMOD",RAX))'=+$G(^(RAX,0)) S RACHANGE=1 Q
G:$G(RACHANGE) QQQ ;
S RAX=0
F S RAX=$O(^RADPT(RAPRIEN(1),"DT",RAPRIEN(2),"P",RAPRIEN(3),"L",RAX)) Q:'RAX I $G(RAPRIEN("TCOM",RAX))'=$G(^(RAX,"TCOM")) S RACHANGE=1 Q
QQQ K RAPRIEN Q RACHANGE
;End of RA*5*82 change
Q ;OK
;In input templates the TECH COMMENT prompt should follow
;TECHNOILOGIST prompt but on the other hand it must be saved
;ONLY with other Activity log fields. That is why we call TCPROMPT
;from template after TECHNOLOGIST prompt and put the content of
;RA18TCOM in the file 70 only in the very end of editing
TCPROMPT() ;called from input templates to immitate prompt
N RA18A,RA18B,RA18C,DIR,Y,X,DA,DTOUT,DUOUT,DIRUT,DIROUT
S RA18A="DESCRIPTION;HELP-PROMPT;INPUT TRANSFORM"
D FIELD^DID(70.07,4,"",RA18A,"RA18B") ;field's parameters
S DIR(0)="FO^3:255^"_RA18B("INPUT TRANSFORM")
S DIR("?")=RA18B("HELP-PROMPT")
S DIR("??")="^D DSCRP^RAO7XX"
S DIR("A")=" TECHNOLOGIST COMMENT"
S RA18C=$$GETTCOM^RAUTL11(RADFN,RADTI,RACNI)
S:RA18C'="" DIR("B")=RA18C
D ^DIR
Q:Y=""!(Y=RA18C) ""
Q Y
;
DSCRP ;get field description
N RA18D S RA18D=0
F S RA18D=$O(RA18B("DESCRIPTION",RA18D)) Q:RA18D="" W !,RA18B("DESCRIPTION",RA18D)
Q
ZZ(RAPTID,RAPFIEN,RAPTIEN) ; Additional text for display when processing alert.
;
S RAPTID=$G(RAPTID) ; IEN of Patient
S RAPFIEN=$G(RAPFIEN) ; IEN of Procedure changed FROM
S RAPTIEN=$G(RAPTIEN) ; IEN of Procedure changed TO
;
N RAPNAM,RAPSSN,RAPRFR,RAPRTO
;
S RAPNAM=$$GET1^DIQ(70,+RAPTID,.01) S:RAPNAM="" RAPNAM="UNKNOWN"
S RAPSSN=$$GET1^DIQ(70,+RAPTID,.09) S:RAPSSN="" RAPSSN="UNKNOWN"
S RAPRFR=$$GET1^DIQ(71,+RAPFIEN,.01) S:RAPRFR="" RAPRFR="UNKNOWN"
S RAPRTO=$$GET1^DIQ(71,+RAPTIEN,.01) S:RAPRTO="" RAPRTO="UNKNOWN"
;
D EN^DDIOL("Imaging Exam For "_$E(RAPNAM,1,30)_" ("_RAPSSN_") Changed:",,"!!?4")
D EN^DDIOL("From: "_RAPRFR,,"!?8")
D EN^DDIOL("To: "_RAPRTO,,"!?8")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAO7XX 9522 printed Apr 09, 2024@21:36:23 Page 2
RAO7XX ;HISC/SS-Sending XX HL7 message to CPRS ;11/19/01 09:07
+1 ;;5.0;Radiology/Nuclear Medicine;**18,26,28,32,82**;Mar 16, 1998;Build 8
+2 ;Check if requested and registered procedures differ in:
+3 ; proc, requesting physician, proc mod(s)
+4 ;if there are changes - send XX message and return 1, otherwise 0
+5 ; called from RAREG2
EN1(RAOIFN1) ;P18 entry point for "Register exams" and "Add to last visit" options
+1 KILL RAREGMOD
+2 if '$DATA(^RAO(75.1,RAOIFN1,0))
QUIT 0
+3 if '$DATA(^RAMIS(71,$PIECE(^RAO(75.1,RAOIFN1,0),"^",2),0))
QUIT 0
+4 NEW RAPRTYPE
SET RAPRTYPE=$PIECE(^RAMIS(71,$PIECE(^RAO(75.1,RAOIFN1,0),"^",2),0),"^",6)
+5 ;quit processing if parent proc, since RAREG2 treats an order, not each descendent of an order, thus no "XX" and no Alert
if RAPRTYPE="P"
QUIT 0
+6 ;no changes or no OR*3*92
IF $$ISCHNGD(RAOIFN1,1)=0
QUIT 0
CHCK ;as a flag for registering mode
NEW RAREGMOD
SET RAREGMOD="R"
+1 ;sends HL7 message
IF $$ORVR^RAORDU()'<3
DO EN1^RAO7NEW(RAOIFN1)
+2 ;proc/reqphys/pmod was changed
QUIT 1
+3 ;
+4 ;Can be used only for EXAMS that DO NOT contain Parent procedures
+5 ;ISSCHNGD Checks: Was original procedure changed?
+6 ;if proc/prc mod/rqstr changed, return 1 to syncrhonize with CPRS
+7 ;Usage: RAIEN751 recNo in 75.1 (like RAOIFN)
+8 ;if SNDALERT=1 sends alert to provider requested the order
+9 ;----------------
ISCHNGD(RAIEN751,SNDALERT) ;P18
+1 NEW RACHANGE,RAX751,RAX70,RASTRING
+2 NEW RAD751
SET RAD751=$GET(^RAO(75.1,RAIEN751,0),-1)
SET RASTRING=""
+3 if RAD751=-1
QUIT 0
+4 NEW RAPAT
SET RAPAT=$PIECE(RAD751,"^",1)
+5 NEW RAD70
SET RAD70=$$FNDIN70(RAPAT,RAIEN751,"V")
+6 NEW RAD70SB
SET RAD70SB=$$FNDIN70(RAPAT,RAIEN751,"T")
+7 if RAD70=0
QUIT 0
+8 ;ien proc from order
NEW RAPR751
SET RAPR751=$PIECE(RAD751,"^",2)
+9 ;ien req phys
NEW RAPHYSID
SET RAPHYSID=$PIECE(RAD751,"^",14)
+10 ;ien proc from exam
SET RAPR70=$PIECE(RAD70,"^",2)
+11 SET RACHANGE=0
+12 ; nonparent,proc changed
IF RAPR751'=RAPR70
IF (RAPRTYPE'="P")
SET RACHANGE=1
SET $PIECE(RASTRING,"/",4,5)=RAPR751_"/"_RAPR70
+13 ;save unchanged proc name
IF RAPR751=RAPR70
IF (RAPRTYPE'="P")
SET $PIECE(RASTRING,"/",4)=RAPR751
+14 ;req phy changed
IF RAPHYSID'=$PIECE(RAD70,"^",14)
SET RACHANGE=1
SET $PIECE(RASTRING,"/",6,7)=RAPHYSID_"/"_$PIECE(RAD70,"^",14)
+15 DO STR751^RAUTL10(.RAX751,RAIEN751)
+16 DO STR70^RAUTL10(.RAX70,RAPAT,$PIECE(RAD70SB,"^"),$PIECE(RAD70SB,"^",2))
+17 ;proc mods changed
IF RAX751'=RAX70
SET RACHANGE=1
SET $PIECE(RASTRING,"/",8,9)=RAX751_"/"_RAX70
+18 if 'RACHANGE
QUIT 0
+19 ;dfn,invdt,case ien
SET $PIECE(RASTRING,"/",1,3)=RAPAT_"/"_$PIECE(RAD70SB,"^")_"/"_$PIECE(RAD70SB,"^",2)
+20 ;recipient of msg
if $PIECE(RASTRING,"/",6)=""
SET $PIECE(RASTRING,"/",6)=RAPHYSID
+21 IF $GET(SNDALERT,0)=1
Begin DoDot:1
+22 IF $$PATCH^XPDUTL("OR*3.0*112")
DO SETNOTIF^RAO7PC4(RAIEN751)
QUIT
+23 DO SETALERT^RAO7PC4
End DoDot:1
B1P18 ;CPRS patch not installed yet-return zero (do not send XX message).Alert has been sent above,because it should be sent anyway
if '$$PATCH^XPDUTL("OR*3.0*92")
QUIT 0
+1 ;one or more changes from orig order AND OR*3*92
QUIT 1
+2 ;
+3 ;RAPT like RADFN
+4 ;RADT like RADTI
+5 ;RACSN like RACN
+6 ;If RARET="V" returns string value, otherwise - $Q of the node
+7 ;if failure returns "0"
FNDIN70M(RAPT,RADT,RACSN,RARET) ;P18
+1 NEW RALV,RALFL
+2 SET (RALV,RALFL)=0
+3 NEW RALVAR2,RAVAL2
+4 SET RALV=$ORDER(^RADPT(RAPT,"DT",RADT,"P","B",RACSN,0))
+5 if +RALV=0
QUIT 0
+6 if RARET="V"
QUIT $GET(^RADPT(RAPT,"DT",RADT,"P",RALV,0),0)
+7 if RARET="T"
QUIT RADT_"^"_RALV
+8 QUIT $QUERY(^RADPT(RAPT,"DT",RADT,"P",RALV))
+9 ;
+10 ;search for #70 entry using PATIEN and Order No from 75.1
+11 ;works correctly ONLY FOR ORDERS that do NOT contain PARENT PROCEDURE
+12 ;RETRN="V" returns value
+13 ;RETRN="T" returns D1^D2 of #70
+14 ;otherwise - $Q
FNDIN70(RAPATN,RAORDN,RETRN) ;
+1 NEW RA18A,RA18B
+2 SET RA18A=$ORDER(^RADPT("AO",RAORDN,RAPATN,0))
+3 if RA18A=""
QUIT 0
+4 SET RA18B=$ORDER(^RADPT("AO",RAORDN,RAPATN,RA18A,0))
+5 if RA18B=""
QUIT 0
+6 if RETRN="V"
QUIT $GET(^RADPT(RAPATN,"DT",RA18A,"P",RA18B,0),0)
+7 if RETRN="T"
QUIT RA18A_"^"_RA18B
+8 QUIT $QUERY(^RADPT(RAPATN,"DT",RA18A,"P",RA18B))
+9 QUIT
+10 ;
+11 ;
UPDTRA0 ;P18 updates var RAO with data from file #70 and sets RAD70SB variable (D2^D3 of #70), called from RAO7NEW
+1 NEW RAD70
+2 SET RAD70=0
+3 ;if registering mode (should not be parent procedure, so we can locate the exam in #70 by OrderN) - data and D2^D3 in #70 for the Order No
+4 if RAREGMOD="R"
SET RAD70=$$FNDIN70(+RA0,RAOIFN,"V")
SET RAD70SB=$$FNDIN70(+RA0,RAOIFN,"T")
+5 ;editing exam had called SVBEFOR, and thus RAPRIEN()s are defined
+6 ;041801 convert null to 0
if RAREGMOD="E"
SET RAD70=$GET(^RADPT(RAPRIEN(1),"DT",RAPRIEN(2),"P",RAPRIEN(3),0))
SET RAD70SB=RAPRIEN(2)_"^"_RAPRIEN(3)
if +RAD70SB=0
SET RAD70SB=0
if +RAD70=0
SET RAD70=0
+7 ; updating info
+8 ; nature of new order activity
IF RAD70=0
SET $PIECE(RA0,"^",26)=""
GOTO ORCSET
+9 ;OBR(4) reset prc only if not parent typ
if $PIECE(^RAMIS(71,+$PIECE(RA0,"^",2),0),"^",6)'="P"
SET $PIECE(RA0,"^",2)=$PIECE(RAD70,"^",2)
+10 ;Contract/Sharing Source
SET $PIECE(RA0,"^",9)=$PIECE(RAD70,"^",9)
+11 ; req phys ORC(12)
SET $PIECE(RA0,"^",14)=$PIECE(RAD70,"^",14)
ORCSET ;ORC(10)
SET $PIECE(RA0,"^",15)=DUZ
+1 QUIT
+2 ;
MODIF70(RA18D1,RA18D2) ;P18 uses data of Modifiers from #70 for OBR(18)
+1 IF $ORDER(^RADPT(+RA0,"DT",RA18D1,"P",RA18D2,"M",0))
Begin DoDot:1
+2 SET (A,RAXIT)=0
+3 FOR
SET A=$ORDER(^RADPT(+RA0,"DT",RA18D1,"P",RA18D2,"M",A))
if A'>0
QUIT
Begin DoDot:2
+4 SET B(0)=$GET(^RADPT(+RA0,"DT",RA18D1,"P",RA18D2,"M",A,0))
+5 SET B(1)=$PIECE($GET(^RAMIS(71.2,+B(0),0)),U)
+6 IF $LENGTH(RA("OBR",18))+$LENGTH(B(1))>60
SET RAXIT=1
QUIT
+7 SET RA("OBR",18)=$GET(RA("OBR",18))_B(1)_RAECH(2)
+8 QUIT
End DoDot:2
if RAXIT
QUIT
+9 SET RA("OBR",18)=$PIECE(RA("OBR",18),RAECH(2),1,$LENGTH(RA("OBR",18),RAECH(2))-1)
+10 QUIT
End DoDot:1
+11 QUIT
SVBEFOR(RAPATN,RAINVDT,RACIEN) ;P18;send radfn,radti,racni (instead of racn and new sequencing of params
+1 DO SVBEFOR^RAO7UTL(RAPATN,RAINVDT,RACIEN)
QUIT
+2 ;Compare proc ien after editing
CMPAFTR(SNDALERT) ;P18
+1 KILL RAREGMOD
+2 IF $DATA(I)
NEW I
+3 IF $DATA(J)
NEW J
+4 IF $DATA(Y)
NEW Y
+5 ;RAPRIEN must be defined by calling SVBEFOR
if '$DATA(RAPRIEN)
QUIT 0
+6 NEW RADATA,RACHANGE,RAX,RA0,RA1,RA2,RA3,RASTRING,RAPRTYPE
+7 SET RASTRING=""
+8 ;=1 if changed any of : proc, proc mod, req phys
SET RACHANGE=0
+9 SET RADATA=$GET(^RADPT(RAPRIEN(1),"DT",RAPRIEN(2),"P",RAPRIEN(3),0))
+10 IF RADATA=""
GOTO CMPEXIT
+11 ;can't process unknown proc type
IF $PIECE(RADATA,"^",11)=""
GOTO CMPEXIT
+12 SET RAPRTYPE=$PIECE($GET(^RAMIS(71,+$PIECE($GET(^RAO(75.1,+$PIECE(RADATA,"^",11),0)),"^",2),0)),"^",6)
+13 ; if parent-type, skip both "XX" and Alert
IF RAPRTYPE="P"
GOTO CMPEXIT
+14 ; compare procedure if it's nonparent
+15 ;nonparent proc--changed
IF $PIECE(RADATA,"^",11)
IF RAPRTYPE'="P"
IF $PIECE(RADATA,"^",2)'=RAPRIEN
SET RACHANGE=1
SET $PIECE(RASTRING,"/",4,5)=RAPRIEN_"/"_$PIECE(RADATA,"^",2)
+16 ;save unchanged proc name
IF $PIECE(RADATA,"^",11)
IF RAPRTYPE'="P"
IF $PIECE(RADATA,"^",2)=RAPRIEN
SET $PIECE(RASTRING,"/",4)=RAPRIEN
+17 ; compare req phys
+18 ;req phy--changed
IF $PIECE(RADATA,"^",14)'=RAPRIEN(4)
SET RACHANGE=1
SET $PIECE(RASTRING,"/",6,7)=RAPRIEN(4)_"/"_$PIECE(RADATA,"^",14)
+19 ; compare proc mods
+20 DO STR70^RAUTL10(.RAX,RAPRIEN(1),RAPRIEN(2),RAPRIEN(3))
+21 ;proc mods-- changed
IF RAPRIEN(5)'=RAX
SET RACHANGE=1
SET $PIECE(RASTRING,"/",8,9)=RAPRIEN(5)_"/"_RAX
+22 IF 'RACHANGE
GOTO CMPEXIT
+23 SET $PIECE(RASTRING,"/",1,3)=RAPRIEN(1)_"/"_RAPRIEN(2)_"/"_RAPRIEN(3)
+24 if $PIECE(RASTRING,"/",6)=""
SET $PIECE(RASTRING,"/",6)=RAPRIEN(4)
+25 ; set up of vars for call to XQALERT or to ORB3
+26 IF $GET(SNDALERT,0)=1
Begin DoDot:1
+27 IF $$PATCH^XPDUTL("OR*3.0*112")
DO SETNOTIF^RAO7PC4($PIECE(RADATA,"^",11))
QUIT
+28 DO SETALERT^RAO7PC4
End DoDot:1
B2P18 if '$$PATCH^XPDUTL("OR*3.0*92")
GOTO CMPEXIT
+1 ;if CPRS patch not installed-don't send any XX message.Checkpoint for all modes except registration,for registration mode see ISCHNGD.Alert has been sent above,because it should be sent anyway
+2 ;edit mode
NEW RAREGMOD
SET RAREGMOD="E"
+3 IF $$ORVR^RAORDU()'<3
DO EN1^RAO7NEW($PIECE(RADATA,"^",11))
CMPEXIT ;
+1 ;Next lines are for RA*5*82
+2 ;If proc, proc mod, req phys changed quit 1
if $GET(RACHANGE)
GOTO QQQ
+3 ;Quit 1 if CPT modifier changed or Tech comments changed
SET RAX=0
+4 FOR
SET RAX=$ORDER(^RADPT(RAPRIEN(1),"DT",RAPRIEN(2),"P",RAPRIEN(3),"CMOD",RAX))
if 'RAX
QUIT
IF $GET(RAPRIEN("CMOD",RAX))'=+$GET(^(RAX,0))
SET RACHANGE=1
QUIT
+5 ;
if $GET(RACHANGE)
GOTO QQQ
+6 SET RAX=0
+7 FOR
SET RAX=$ORDER(^RADPT(RAPRIEN(1),"DT",RAPRIEN(2),"P",RAPRIEN(3),"L",RAX))
if 'RAX
QUIT
IF $GET(RAPRIEN("TCOM",RAX))'=$GET(^(RAX,"TCOM"))
SET RACHANGE=1
QUIT
QQQ KILL RAPRIEN
QUIT RACHANGE
+1 ;End of RA*5*82 change
+2 ;OK
QUIT
+3 ;In input templates the TECH COMMENT prompt should follow
+4 ;TECHNOILOGIST prompt but on the other hand it must be saved
+5 ;ONLY with other Activity log fields. That is why we call TCPROMPT
+6 ;from template after TECHNOLOGIST prompt and put the content of
+7 ;RA18TCOM in the file 70 only in the very end of editing
TCPROMPT() ;called from input templates to immitate prompt
+1 NEW RA18A,RA18B,RA18C,DIR,Y,X,DA,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET RA18A="DESCRIPTION;HELP-PROMPT;INPUT TRANSFORM"
+3 ;field's parameters
DO FIELD^DID(70.07,4,"",RA18A,"RA18B")
+4 SET DIR(0)="FO^3:255^"_RA18B("INPUT TRANSFORM")
+5 SET DIR("?")=RA18B("HELP-PROMPT")
+6 SET DIR("??")="^D DSCRP^RAO7XX"
+7 SET DIR("A")=" TECHNOLOGIST COMMENT"
+8 SET RA18C=$$GETTCOM^RAUTL11(RADFN,RADTI,RACNI)
+9 if RA18C'=""
SET DIR("B")=RA18C
+10 DO ^DIR
+11 if Y=""!(Y=RA18C)
QUIT ""
+12 QUIT Y
+13 ;
DSCRP ;get field description
+1 NEW RA18D
SET RA18D=0
+2 FOR
SET RA18D=$ORDER(RA18B("DESCRIPTION",RA18D))
if RA18D=""
QUIT
WRITE !,RA18B("DESCRIPTION",RA18D)
+3 QUIT
ZZ(RAPTID,RAPFIEN,RAPTIEN) ; Additional text for display when processing alert.
+1 ;
+2 ; IEN of Patient
SET RAPTID=$GET(RAPTID)
+3 ; IEN of Procedure changed FROM
SET RAPFIEN=$GET(RAPFIEN)
+4 ; IEN of Procedure changed TO
SET RAPTIEN=$GET(RAPTIEN)
+5 ;
+6 NEW RAPNAM,RAPSSN,RAPRFR,RAPRTO
+7 ;
+8 SET RAPNAM=$$GET1^DIQ(70,+RAPTID,.01)
if RAPNAM=""
SET RAPNAM="UNKNOWN"
+9 SET RAPSSN=$$GET1^DIQ(70,+RAPTID,.09)
if RAPSSN=""
SET RAPSSN="UNKNOWN"
+10 SET RAPRFR=$$GET1^DIQ(71,+RAPFIEN,.01)
if RAPRFR=""
SET RAPRFR="UNKNOWN"
+11 SET RAPRTO=$$GET1^DIQ(71,+RAPTIEN,.01)
if RAPRTO=""
SET RAPRTO="UNKNOWN"
+12 ;
+13 DO EN^DDIOL("Imaging Exam For "_$EXTRACT(RAPNAM,1,30)_" ("_RAPSSN_") Changed:",,"!!?4")
+14 DO EN^DDIOL("From: "_RAPRFR,,"!?8")
+15 DO EN^DDIOL("To: "_RAPRTO,,"!?8")
+16 QUIT
+17 ;
