- 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 Feb 19, 2025@00:04:16 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 ;