RAO7MFN ;HISC/GJC-Create MFN orderable item update msg ; May 28, 2020@08:01:53
;;5.0;Radiology/Nuclear Medicine;**1,6,10,18,45,158,165**;Mar 16, 1998;Build 3
;Last midification by SS for P18 JUN 19, 2000
;Last modification: 12.16.03 patch 45 Contrast Media by CPT gjc
PROC(RAENALL,RAFILE,RASTAT,RAY) ; Entry point to update a single procedure.
; 'RAY' <> is the same as 'Y' when passed back from DIC after
; lookup on file 71 & file 71.3
; 'RAENALL'<> single procedure (0) or whole file update (1) flag
; 'RAFILE' <> file # of the file being edited (71 or 71.3)
; 'RASTAT' <> Procedure file (71) status: 0 inactive^1 active
; Com. Proc. file (71.3) Seq. # status: 0 inactive^1 active
; 1st piece: status before edit, 2nd piece: status after
; edit.
; This entry point can be called from 2^RAMAIN2 or 13^RAMAIN2
; This routine assumes that RAVAR is defined as an array or global
; root in which to place the output.
;
Q:'$D(RAY)!('$D(RAFILE))!('$D(RASTAT))!('$D(RAENALL))
S RAFNUM=71,RAFNAME=$P($G(^DIC(RAFNUM,0)),"^"),RAXIT=0
S:'$D(RATSTMP) RATSTMP=$$NOW^XLFDT()
S:'$D(RACNT) RACNT=0 S:'$D(RAINCR) RAINCR="S RACNT=RACNT+1"
S:'$D(RASUB) RASUB="""RAO7"""
D:'$D(RAHLFS)!('$D(RAECH)) EN1^RAO7UTL
I 'RAENALL,('$D(RAVAR)) D
. S RAVAR="^TMP("_RASUB_","_RATSTMP_","
. S RAVARBLE="^TMP("_RASUB_","_RATSTMP_")"
. Q
I RAFILE=71 D
. S RA71(0)=$G(^RAMIS(RAFILE,+RAY,0))
. S RA71("I")=$G(^RAMIS(RAFILE,+RAY,"I"))
. I $D(^RAMIS(71.3,"B",+RAY)) D
.. S RA713(0)=$G(^RAMIS(71.3,+$O(^RAMIS(71.3,"B",+RAY,0)),0))
.. Q
. Q
I RAFILE=71.3 D
. S RA713(0)=$G(^RAMIS(RAFILE,+RAY,0))
. ; if RA713(0)="" then the common procedure was deleted
. S RASVIEN=$S(+RA713(0)>0:+RA713(0),1:+$P(RAY,"^",2))
. S RA71(0)=$G(^RAMIS(71,RASVIEN,0))
. S RA71("I")=$G(^RAMIS(71,RASVIEN,"I"))
. K RASVIEN
. Q
Q:$$PROCNDE^RAO7UTL(.RA71) ; Does the Proc. have Proc-Types & I-Types
I RAFILE=71 D
.I +$P(RAY,"^",3) D
..;new entry, add to master file whether active or inactive
..S RAMFE="MAD"
..Q
.I '+$P(RAY,"^",3),(+$P(RASTAT,"^",2)) D
..;now active regardless of prior status, update master file
..S RAMFE="MUP"
..Q
.I '+$P(RAY,"^",3),('+$P(RASTAT,"^",2)) D
..;now inactive regardless of prior status, deactivate master file
..S RAMFE="MDC"
..Q
.Q
; If RAMFE is still not defined, must be an addition to common orders
; 'Update' to OE since procedure is already in their master file
I RAFILE=71.3 S RAMFE="MUP"
;
; If parent with no descendents, send deactivate msg even if active /p165 - Check RA165 flag
I $P($G(RA71(0)),"^",6)="P",'$O(^RAMIS(71,$S(RAFILE=71.3:+$P(RAY,"^",2),1:+RAY),4,0)),'$G(RA165) S RAMFE="MDC"
;
;* begin 1 * build the non-repeating message segments (MSH, MFI) once
I 'RAENALL D
. X RAINCR
. S @(RAVAR_RACNT_")")=$$MSH^RAO7UTL("MFN^M01") X RAINCR ;P18 event type
. D MFI^RAO7UTL("UPD") ;P18
. Q
;* end 1 *
;
;if var1 '= var2 translated:
;the user changed the procedure for this common...
;if the current pointed to procedure (var1) differs
;from the original pointed to procedure (var2)
I RAFILE=71.3,$P(RAMIS713(0),U)>0,($P(RAMIS713(0),U)'=$P(RAY,U,2)) D
.;first tackle the 'changed to' procedure (is common)
.S RA713(0)=RAMIS713(0)
.S RA71(0)=$G(^RAMIS(71,+RAMIS713(0),0))
.S RA71("I")=$G(^RAMIS(71,+RAMIS713(0),"I"))
.D MSGBODY($P($G(RA713(0)),"^",4)) ;pass sequence number
.;now tackle the 'changed from' procedure (not common)
.S RA713(0)=$P(RAY,U,2)_"^^^" ;4th piece seq. num.
.S RA71(0)=$G(^RAMIS(71,+RA713(0),0))
.S RA71("I")=$G(^RAMIS(71,+RA713(0),"I"))
.D MSGBODY(0) ;'0' indicates not a common
.Q
D MSGBODY("") ;determine the common flag on the fly.
;
I 'RAENALL D
. D MSG^XQOR("RA ORDERABLE ITEM UPDATE",RAVARBLE)
. D PURGE^RAO7UTL
. Q
X:RAENALL RAINCR
;
Q
ENALL ; Whole Rad/Nuc Med Procedure file update. Called only when Rad/Nuc
; Med or OE/RR are being installed.
QUIT ;never execute this code disabled w/RA5P158
Q:'$D(XPDNM) ; quit if not KIDS, xists during pre/post inits
; & environment check routines.
L +^RAMIS(71.3):300 D ^RACOMDEL L -^RAMIS(71.3)
L +^RAMIS(71):300
I '$T D Q
. N TXT S TXT(1)=" "
. S TXT(2)="Another user is editing a record in the "
. S TXT(2)=TXT(2)_$P($G(^DIC(71,0)),"^")
. S TXT(3)="file. Try again later!"
. S XPDQUIT=1 D MES^XPDUTL(.TXT)
. Q
N RA,RACNT,RAECH,RAENALL,RAFILE,RAFNAME,RAFNUM,RAHLFS,RAINCR,RASTAT
N RASUB,RATSTMP,RAVAR,RAXIT,RAY
S (RA,RACNT)=0,RAENALL=1,RATSTMP=$$NOW^XLFDT(),RAINCR="S RACNT=RACNT+1"
S RASUB="""RAO7""",RAVAR="^TMP("_RASUB_","_RATSTMP_","
S RAVARBLE="^TMP("_RASUB_","_RATSTMP_")"
D EN1^RAO7UTL ; sets up RAECH & RAHLFS
S (RAFILE,RAFNUM)=71,RAFNAME=$P($G(^DIC(RAFNUM,0)),"^"),RASTAT="0^1"
X RAINCR S @(RAVAR_RACNT_")")=$$MSH^RAO7UTL("MFN^M01") X RAINCR ;P18 event type
D MFI^RAO7UTL("REP")
F S RA=$O(^RAMIS(71,RA)) Q:RA'>0 D D PURGE1^RAO7UTL
. S RA(0)=$G(^RAMIS(71,RA,0)),RA("I")=$G(^RAMIS(71,RA,"I"))
. Q:$P(RA("I"),"^")]""&($P(RA("I"),"^")'>DT) ; inactive date present
. S RAY=RA_"^"_$P(RA(0),"^")_"^"_1 D PROC(RAENALL,RAFILE,RASTAT,RAY)
. Q
D EN^ORMFN(RAVARBLE) K @RAVARBLE,RAVARBLE
L -^RAMIS(71) ; unlock whole file
PARM ;Send Div params for SUBMIT TO prompt and allowing BROAD procedures
;to OE3 so they can populate their OE/RR Parameter Instance file
N DIK S DIK="^RA(79,",DIK(1)=".121^AC1" D ENALL^DIK
N DIK S DIK="^RA(79,",DIK(1)=".17^AC" D ENALL^DIK
Q
;
MSGBODY(RASEQNUM) ;Build the HL7 message to be broadcast to CPRS RA5P158
;if the common is question has a sequence number use it
;Input: RASEQNUM > 0 if a common procedure (w/seq. #)
; RASEQNUM = 0 if not a common procedure (w/o seq. #)
; RASEQNUM = "" if common procedure status is settled w/ old logic
;
S RACPT(0)=$$NAMCODE^RACPTMSC(+$P(RA71(0),"^",9),DT)
S:RAFILE=71 RAIEN71=+RAY S:RAFILE=71.3 RAIEN71=+$P(RAY,"^",2)
S RAXT71=$P(RA71(0),"^")
S RAIMGAB=$P($G(^RA(79.2,+$P(RA71(0),"^",12),0)),"^",3)
S RAPHYAP=$S($P(RA71(0),"^",11)="":"","Yy"[$P(RA71(0),"^",11):"Y",1:"N")
S RACOST=$P(RA71(0),"^",10),RAPRCTY=$P(RA71(0),"^",6)
S:RASEQNUM>0 RACMNOR="Y"
S:RASEQNUM=0 RACMNOR="N"
;if this is not a case where the procedure for the common was not changed
;determine if it is to be a common from the old logic pre 158
S:RASEQNUM="" RACMNOR=$S($P($G(RA713(0)),"^",4)]"":"Y",1:"N")
;
;determine CM associations for active & inactive procedures
S RACMCODE=$$CMEDIA^RAO7UTL(RAIEN71,$P(RA71(0),U,6)) ;ien, proc. type
S RAINACT=$S(RA71("I")]"":$$HLDATE^HLFNC(RA71("I"),"DT"),1:"")
S @(RAVAR_RACNT_")")="MFE"_RAHLFS_RAMFE_RAHLFS_RAHLFS_RAINACT_RAHLFS
S @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_$P(RACPT(0),"^")
S @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RAECH(1)
S @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_$P(RACPT(0),"^",2)
S @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RAECH(1)_"CPT4"
S @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RAECH(1)_RAIEN71
S @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RAECH(1)_RAXT71
S @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RAECH(1)_"99RAP"
K RAINACT X RAINCR
S @(RAVAR_RACNT_")")="ZRA"_RAHLFS_RAIMGAB_RAHLFS_RAPHYAP
S @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RAHLFS_RACOST_RAHLFS
S @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_$G(RACMCODE)_RAHLFS
S @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RACMNOR_RAHLFS
S @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RAPRCTY_RAHLFS
; Check the synonym (1), message (3) and the Education Description
; "EDU" multiples for data
N I,J,K,RAPMSG S RAPMSG=0
F RAMULT="^RAMIS(71,"_RAIEN71_",1,","^RAMIS(71,"_RAIEN71_",3,","^RAMIS(71,"_RAIEN71_",""EDU""," D
. I RAMULT=("^RAMIS(71,"_RAIEN71_",""EDU"","),($$UP^XLFSTR($P(RA71(0),"^",17))'="Y") Q ; display Ed Descr not set to yes, quit
. Q:'+$O(@(RAMULT_"0)")) ; no data for 1 synonym, 3 message, "EDU" desc multiple
. S (I,J)=0,K=""
. F S J=$O(@(RAMULT_J_")")) Q:J'>0 D
.. S K=$G(@(RAMULT_J_",0)"))
.. I RAMULT=("^RAMIS(71,"_RAIEN71_",1,") D Q
... X RAINCR S I=I+1
... S @(RAVAR_RACNT_")")="ZSY"_RAHLFS_I_RAHLFS_$P(K,"^")
... Q
.. I RAMULT=("^RAMIS(71,"_RAIEN71_",3,") D
... X RAINCR S I=I+1,RAPMSG=1
... S @(RAVAR_RACNT_")")="NTE"_RAHLFS_I_RAHLFS_RAHLFS_$P($G(^RAMIS(71.4,+K,0)),"^")
... Q
.. I RAMULT=("^RAMIS(71,"_RAIEN71_",""EDU"",") D
... I RAPMSG D
.... X RAINCR S I=I+1
.... S @(RAVAR_RACNT_")")="NTE"_RAHLFS_I_RAHLFS_RAHLFS_" "
.... S RAPMSG=0
.... Q
... X RAINCR S I=I+1
... S @(RAVAR_RACNT_")")="NTE"_RAHLFS_I_RAHLFS_RAHLFS_K
... Q
.. Q
. Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAO7MFN 8613 printed Apr 09, 2024@21:37:01 Page 2
RAO7MFN ;HISC/GJC-Create MFN orderable item update msg ; May 28, 2020@08:01:53
+1 ;;5.0;Radiology/Nuclear Medicine;**1,6,10,18,45,158,165**;Mar 16, 1998;Build 3
+2 ;Last midification by SS for P18 JUN 19, 2000
+3 ;Last modification: 12.16.03 patch 45 Contrast Media by CPT gjc
PROC(RAENALL,RAFILE,RASTAT,RAY) ; Entry point to update a single procedure.
+1 ; 'RAY' <> is the same as 'Y' when passed back from DIC after
+2 ; lookup on file 71 & file 71.3
+3 ; 'RAENALL'<> single procedure (0) or whole file update (1) flag
+4 ; 'RAFILE' <> file # of the file being edited (71 or 71.3)
+5 ; 'RASTAT' <> Procedure file (71) status: 0 inactive^1 active
+6 ; Com. Proc. file (71.3) Seq. # status: 0 inactive^1 active
+7 ; 1st piece: status before edit, 2nd piece: status after
+8 ; edit.
+9 ; This entry point can be called from 2^RAMAIN2 or 13^RAMAIN2
+10 ; This routine assumes that RAVAR is defined as an array or global
+11 ; root in which to place the output.
+12 ;
+13 if '$DATA(RAY)!('$DATA(RAFILE))!('$DATA(RASTAT))!('$DATA(RAENALL))
QUIT
+14 SET RAFNUM=71
SET RAFNAME=$PIECE($GET(^DIC(RAFNUM,0)),"^")
SET RAXIT=0
+15 if '$DATA(RATSTMP)
SET RATSTMP=$$NOW^XLFDT()
+16 if '$DATA(RACNT)
SET RACNT=0
if '$DATA(RAINCR)
SET RAINCR="S RACNT=RACNT+1"
+17 if '$DATA(RASUB)
SET RASUB="""RAO7"""
+18 if '$DATA(RAHLFS)!('$DATA(RAECH))
DO EN1^RAO7UTL
+19 IF 'RAENALL
IF ('$DATA(RAVAR))
Begin DoDot:1
+20 SET RAVAR="^TMP("_RASUB_","_RATSTMP_","
+21 SET RAVARBLE="^TMP("_RASUB_","_RATSTMP_")"
+22 QUIT
End DoDot:1
+23 IF RAFILE=71
Begin DoDot:1
+24 SET RA71(0)=$GET(^RAMIS(RAFILE,+RAY,0))
+25 SET RA71("I")=$GET(^RAMIS(RAFILE,+RAY,"I"))
+26 IF $DATA(^RAMIS(71.3,"B",+RAY))
Begin DoDot:2
+27 SET RA713(0)=$GET(^RAMIS(71.3,+$ORDER(^RAMIS(71.3,"B",+RAY,0)),0))
+28 QUIT
End DoDot:2
+29 QUIT
End DoDot:1
+30 IF RAFILE=71.3
Begin DoDot:1
+31 SET RA713(0)=$GET(^RAMIS(RAFILE,+RAY,0))
+32 ; if RA713(0)="" then the common procedure was deleted
+33 SET RASVIEN=$SELECT(+RA713(0)>0:+RA713(0),1:+$PIECE(RAY,"^",2))
+34 SET RA71(0)=$GET(^RAMIS(71,RASVIEN,0))
+35 SET RA71("I")=$GET(^RAMIS(71,RASVIEN,"I"))
+36 KILL RASVIEN
+37 QUIT
End DoDot:1
+38 ; Does the Proc. have Proc-Types & I-Types
if $$PROCNDE^RAO7UTL(.RA71)
QUIT
+39 IF RAFILE=71
Begin DoDot:1
+40 IF +$PIECE(RAY,"^",3)
Begin DoDot:2
+41 ;new entry, add to master file whether active or inactive
+42 SET RAMFE="MAD"
+43 QUIT
End DoDot:2
+44 IF '+$PIECE(RAY,"^",3)
IF (+$PIECE(RASTAT,"^",2))
Begin DoDot:2
+45 ;now active regardless of prior status, update master file
+46 SET RAMFE="MUP"
+47 QUIT
End DoDot:2
+48 IF '+$PIECE(RAY,"^",3)
IF ('+$PIECE(RASTAT,"^",2))
Begin DoDot:2
+49 ;now inactive regardless of prior status, deactivate master file
+50 SET RAMFE="MDC"
+51 QUIT
End DoDot:2
+52 QUIT
End DoDot:1
+53 ; If RAMFE is still not defined, must be an addition to common orders
+54 ; 'Update' to OE since procedure is already in their master file
+55 IF RAFILE=71.3
SET RAMFE="MUP"
+56 ;
+57 ; If parent with no descendents, send deactivate msg even if active /p165 - Check RA165 flag
+58 IF $PIECE($GET(RA71(0)),"^",6)="P"
IF '$ORDER(^RAMIS(71,$SELECT(RAFILE=71.3:+$PIECE(RAY,"^",2),1:+RAY),4,0))
IF '$GET(RA165)
SET RAMFE="MDC"
+59 ;
+60 ;* begin 1 * build the non-repeating message segments (MSH, MFI) once
+61 IF 'RAENALL
Begin DoDot:1
+62 XECUTE RAINCR
+63 ;P18 event type
SET @(RAVAR_RACNT_")")=$$MSH^RAO7UTL("MFN^M01")
XECUTE RAINCR
+64 ;P18
DO MFI^RAO7UTL("UPD")
+65 QUIT
End DoDot:1
+66 ;* end 1 *
+67 ;
+68 ;if var1 '= var2 translated:
+69 ;the user changed the procedure for this common...
+70 ;if the current pointed to procedure (var1) differs
+71 ;from the original pointed to procedure (var2)
+72 IF RAFILE=71.3
IF $PIECE(RAMIS713(0),U)>0
IF ($PIECE(RAMIS713(0),U)'=$PIECE(RAY,U,2))
Begin DoDot:1
+73 ;first tackle the 'changed to' procedure (is common)
+74 SET RA713(0)=RAMIS713(0)
+75 SET RA71(0)=$GET(^RAMIS(71,+RAMIS713(0),0))
+76 SET RA71("I")=$GET(^RAMIS(71,+RAMIS713(0),"I"))
+77 ;pass sequence number
DO MSGBODY($PIECE($GET(RA713(0)),"^",4))
+78 ;now tackle the 'changed from' procedure (not common)
+79 ;4th piece seq. num.
SET RA713(0)=$PIECE(RAY,U,2)_"^^^"
+80 SET RA71(0)=$GET(^RAMIS(71,+RA713(0),0))
+81 SET RA71("I")=$GET(^RAMIS(71,+RA713(0),"I"))
+82 ;'0' indicates not a common
DO MSGBODY(0)
+83 QUIT
End DoDot:1
+84 ;determine the common flag on the fly.
DO MSGBODY("")
+85 ;
+86 IF 'RAENALL
Begin DoDot:1
+87 DO MSG^XQOR("RA ORDERABLE ITEM UPDATE",RAVARBLE)
+88 DO PURGE^RAO7UTL
+89 QUIT
End DoDot:1
+90 if RAENALL
XECUTE RAINCR
+91 ;
+92 QUIT
ENALL ; Whole Rad/Nuc Med Procedure file update. Called only when Rad/Nuc
+1 ; Med or OE/RR are being installed.
+2 ;never execute this code disabled w/RA5P158
QUIT
+3 ; quit if not KIDS, xists during pre/post inits
if '$DATA(XPDNM)
QUIT
+4 ; & environment check routines.
+5 LOCK +^RAMIS(71.3):300
DO ^RACOMDEL
LOCK -^RAMIS(71.3)
+6 LOCK +^RAMIS(71):300
+7 IF '$TEST
Begin DoDot:1
+8 NEW TXT
SET TXT(1)=" "
+9 SET TXT(2)="Another user is editing a record in the "
+10 SET TXT(2)=TXT(2)_$PIECE($GET(^DIC(71,0)),"^")
+11 SET TXT(3)="file. Try again later!"
+12 SET XPDQUIT=1
DO MES^XPDUTL(.TXT)
+13 QUIT
End DoDot:1
QUIT
+14 NEW RA,RACNT,RAECH,RAENALL,RAFILE,RAFNAME,RAFNUM,RAHLFS,RAINCR,RASTAT
+15 NEW RASUB,RATSTMP,RAVAR,RAXIT,RAY
+16 SET (RA,RACNT)=0
SET RAENALL=1
SET RATSTMP=$$NOW^XLFDT()
SET RAINCR="S RACNT=RACNT+1"
+17 SET RASUB="""RAO7"""
SET RAVAR="^TMP("_RASUB_","_RATSTMP_","
+18 SET RAVARBLE="^TMP("_RASUB_","_RATSTMP_")"
+19 ; sets up RAECH & RAHLFS
DO EN1^RAO7UTL
+20 SET (RAFILE,RAFNUM)=71
SET RAFNAME=$PIECE($GET(^DIC(RAFNUM,0)),"^")
SET RASTAT="0^1"
+21 ;P18 event type
XECUTE RAINCR
SET @(RAVAR_RACNT_")")=$$MSH^RAO7UTL("MFN^M01")
XECUTE RAINCR
+22 DO MFI^RAO7UTL("REP")
+23 FOR
SET RA=$ORDER(^RAMIS(71,RA))
if RA'>0
QUIT
Begin DoDot:1
+24 SET RA(0)=$GET(^RAMIS(71,RA,0))
SET RA("I")=$GET(^RAMIS(71,RA,"I"))
+25 ; inactive date present
if $PIECE(RA("I"),"^")]""&($PIECE(RA("I"),"^")'>DT)
QUIT
+26 SET RAY=RA_"^"_$PIECE(RA(0),"^")_"^"_1
DO PROC(RAENALL,RAFILE,RASTAT,RAY)
+27 QUIT
End DoDot:1
DO PURGE1^RAO7UTL
+28 DO EN^ORMFN(RAVARBLE)
KILL @RAVARBLE,RAVARBLE
+29 ; unlock whole file
LOCK -^RAMIS(71)
PARM ;Send Div params for SUBMIT TO prompt and allowing BROAD procedures
+1 ;to OE3 so they can populate their OE/RR Parameter Instance file
+2 NEW DIK
SET DIK="^RA(79,"
SET DIK(1)=".121^AC1"
DO ENALL^DIK
+3 NEW DIK
SET DIK="^RA(79,"
SET DIK(1)=".17^AC"
DO ENALL^DIK
+4 QUIT
+5 ;
MSGBODY(RASEQNUM) ;Build the HL7 message to be broadcast to CPRS RA5P158
+1 ;if the common is question has a sequence number use it
+2 ;Input: RASEQNUM > 0 if a common procedure (w/seq. #)
+3 ; RASEQNUM = 0 if not a common procedure (w/o seq. #)
+4 ; RASEQNUM = "" if common procedure status is settled w/ old logic
+5 ;
+6 SET RACPT(0)=$$NAMCODE^RACPTMSC(+$PIECE(RA71(0),"^",9),DT)
+7 if RAFILE=71
SET RAIEN71=+RAY
if RAFILE=71.3
SET RAIEN71=+$PIECE(RAY,"^",2)
+8 SET RAXT71=$PIECE(RA71(0),"^")
+9 SET RAIMGAB=$PIECE($GET(^RA(79.2,+$PIECE(RA71(0),"^",12),0)),"^",3)
+10 SET RAPHYAP=$SELECT($PIECE(RA71(0),"^",11)="":"","Yy"[$PIECE(RA71(0),"^",11):"Y",1:"N")
+11 SET RACOST=$PIECE(RA71(0),"^",10)
SET RAPRCTY=$PIECE(RA71(0),"^",6)
+12 if RASEQNUM>0
SET RACMNOR="Y"
+13 if RASEQNUM=0
SET RACMNOR="N"
+14 ;if this is not a case where the procedure for the common was not changed
+15 ;determine if it is to be a common from the old logic pre 158
+16 if RASEQNUM=""
SET RACMNOR=$SELECT($PIECE($GET(RA713(0)),"^",4)]"":"Y",1:"N")
+17 ;
+18 ;determine CM associations for active & inactive procedures
+19 ;ien, proc. type
SET RACMCODE=$$CMEDIA^RAO7UTL(RAIEN71,$PIECE(RA71(0),U,6))
+20 SET RAINACT=$SELECT(RA71("I")]"":$$HLDATE^HLFNC(RA71("I"),"DT"),1:"")
+21 SET @(RAVAR_RACNT_")")="MFE"_RAHLFS_RAMFE_RAHLFS_RAHLFS_RAINACT_RAHLFS
+22 SET @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_$PIECE(RACPT(0),"^")
+23 SET @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RAECH(1)
+24 SET @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_$PIECE(RACPT(0),"^",2)
+25 SET @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RAECH(1)_"CPT4"
+26 SET @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RAECH(1)_RAIEN71
+27 SET @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RAECH(1)_RAXT71
+28 SET @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RAECH(1)_"99RAP"
+29 KILL RAINACT
XECUTE RAINCR
+30 SET @(RAVAR_RACNT_")")="ZRA"_RAHLFS_RAIMGAB_RAHLFS_RAPHYAP
+31 SET @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RAHLFS_RACOST_RAHLFS
+32 SET @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_$GET(RACMCODE)_RAHLFS
+33 SET @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RACMNOR_RAHLFS
+34 SET @(RAVAR_RACNT_")")=@(RAVAR_RACNT_")")_RAPRCTY_RAHLFS
+35 ; Check the synonym (1), message (3) and the Education Description
+36 ; "EDU" multiples for data
+37 NEW I,J,K,RAPMSG
SET RAPMSG=0
+38 FOR RAMULT="^RAMIS(71,"_RAIEN71_",1,","^RAMIS(71,"_RAIEN71_",3,","^RAMIS(71,"_RAIEN71_",""EDU"","
Begin DoDot:1
+39 ; display Ed Descr not set to yes, quit
IF RAMULT=("^RAMIS(71,"_RAIEN71_",""EDU"",")
IF ($$UP^XLFSTR($PIECE(RA71(0),"^",17))'="Y")
QUIT
+40 ; no data for 1 synonym, 3 message, "EDU" desc multiple
if '+$ORDER(@(RAMULT_"0)"))
QUIT
+41 SET (I,J)=0
SET K=""
+42 FOR
SET J=$ORDER(@(RAMULT_J_")"))
if J'>0
QUIT
Begin DoDot:2
+43 SET K=$GET(@(RAMULT_J_",0)"))
+44 IF RAMULT=("^RAMIS(71,"_RAIEN71_",1,")
Begin DoDot:3
+45 XECUTE RAINCR
SET I=I+1
+46 SET @(RAVAR_RACNT_")")="ZSY"_RAHLFS_I_RAHLFS_$PIECE(K,"^")
+47 QUIT
End DoDot:3
QUIT
+48 IF RAMULT=("^RAMIS(71,"_RAIEN71_",3,")
Begin DoDot:3
+49 XECUTE RAINCR
SET I=I+1
SET RAPMSG=1
+50 SET @(RAVAR_RACNT_")")="NTE"_RAHLFS_I_RAHLFS_RAHLFS_$PIECE($GET(^RAMIS(71.4,+K,0)),"^")
+51 QUIT
End DoDot:3
+52 IF RAMULT=("^RAMIS(71,"_RAIEN71_",""EDU"",")
Begin DoDot:3
+53 IF RAPMSG
Begin DoDot:4
+54 XECUTE RAINCR
SET I=I+1
+55 SET @(RAVAR_RACNT_")")="NTE"_RAHLFS_I_RAHLFS_RAHLFS_" "
+56 SET RAPMSG=0
+57 QUIT
End DoDot:4
+58 XECUTE RAINCR
SET I=I+1
+59 SET @(RAVAR_RACNT_")")="NTE"_RAHLFS_I_RAHLFS_RAHLFS_K
+60 QUIT
End DoDot:3
+61 QUIT
End DoDot:2
+62 QUIT
End DoDot:1
+63 QUIT
+64 ;
