RACOMDEL ;HIRMFO/GJC-Utility, remove duplicates in ^RAMIS(71.3 ;7/10/97 09:17
VERSION ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
;
; This routine is called from the RAO7MFN routine after initial
; population of CPRS (OE/RR v3) Orderable Items file.
; Deletes all but one instance of a procedure in the Rad/Nuc Med
; Common Procedure file.
K RA1,RA2,RA3,RACNT,RAIEN,RAPROC,^TMP($J,"RA CMMN PROC") S RAPROC=0
F S RAPROC=$O(^RAMIS(71.3,"B",RAPROC)) Q:RAPROC'>0 D
. S (RACNT,RAIEN)=0
. F S RAIEN=+$O(^RAMIS(71.3,"B",RAPROC,RAIEN)) Q:RAIEN'>0 D
.. S RACNT=RACNT+1 D:RACNT>1 SAVE
.. Q
. Q
I '$D(^TMP($J,"RA CMMN PROC")) D XIT Q
S RA1=0
F S RA1=$O(^TMP($J,"RA CMMN PROC",RA1)) Q:RA1'>0 D ;file 71 ien
. S RA2="",RACNT=0
. F S RA2=$O(^TMP($J,"RA CMMN PROC",RA1,RA2)) Q:RA2']"" D ;active?
.. S RA3=0
.. F S RA3=$O(^TMP($J,"RA CMMN PROC",RA1,RA2,RA3)) Q:RA3'>0 D ;71.3
... S RACNT=RACNT+1 D:RACNT>1 PURGE(RA3)
... Q
.. Q
. Q
D RESEQ ; re-sequence common procedures
XIT ; Kill variables and quit
K RA1,RA2,RA3,RACNT,RAIEN,RAPROC,^TMP($J,"RA CMMN PROC")
Q
PURGE(DA) ; Delete duplicate common procedures saving the first
; occurrence of our common in question. Data is stored so that active
; common procedures will sort first.
; Input: DA-ien of entry in 71.3 to be deleted!
K %,DIC,DIK,X,Y S DIK="^RAMIS(71.3," D ^DIK K %,DIC,DIK,X,Y
Q
SAVE ; Save off all common procedure data when more than one occurrence.
K RA713,RACTIV
I RACNT=2 D
. N RAIEN S RAIEN=+$O(^RAMIS(71.3,"B",RAPROC,0)) Q:'RAIEN
. S RA713=$G(^RAMIS(71.3,RAIEN,0)) Q:RA713']""
. S RACTIV=$S($P(RA713,"^",5)]"":1,1:0)
. D SET
. Q
S RA713=$G(^RAMIS(71.3,RAIEN,0)) Q:RA713']""
S RACTIV=$S($P(RA713,"^",5)]"":1,1:0) D SET
K RA713,RACTIV
Q
SET ; Set the ^TMP($J,"RA CMMN PROC") global.
; RAPROC=pntr to file 71, RAIEN=ien in file 71.3
; RACTIV=Active flag: 1 for inactive, 0 for active
S ^TMP($J,"RA CMMN PROC",RAPROC,RACTIV,RAIEN)=""
Q
RESEQ ;Resequence the common procedure list for all imaging types
N D,DA,D0,DI,DIC,DIE,DQ,DR,RACNT,RAI,RAIMGTYI,RAJ,X,Y
S DIE="^RAMIS(71.3,",RAIMGTYI=0
F S RAIMGTYI=$O(^RAMIS(71.3,"AA",RAIMGTYI)) Q:RAIMGTYI'>0 D
. S (RAI,RACNT)=0
. F S RAI=$O(^RAMIS(71.3,"AA",RAIMGTYI,RAI)) Q:RAI'>0 D
.. S RAJ=0
.. F S RAJ=$O(^RAMIS(71.3,"AA",RAIMGTYI,RAI,RAJ)) Q:RAJ'>0 I $D(^RAMIS(71.3,RAJ,0)) D
... S DA=RAJ,RACNT=RACNT+1
... S DR="3////^S X=RACNT" D ^DIE
... Q
.. Q
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRACOMDEL 2496 printed Dec 13, 2024@02:34:10 Page 2
RACOMDEL ;HIRMFO/GJC-Utility, remove duplicates in ^RAMIS(71.3 ;7/10/97 09:17
VERSION ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+1 ;
+2 ; This routine is called from the RAO7MFN routine after initial
+3 ; population of CPRS (OE/RR v3) Orderable Items file.
+4 ; Deletes all but one instance of a procedure in the Rad/Nuc Med
+5 ; Common Procedure file.
+6 KILL RA1,RA2,RA3,RACNT,RAIEN,RAPROC,^TMP($JOB,"RA CMMN PROC")
SET RAPROC=0
+7 FOR
SET RAPROC=$ORDER(^RAMIS(71.3,"B",RAPROC))
if RAPROC'>0
QUIT
Begin DoDot:1
+8 SET (RACNT,RAIEN)=0
+9 FOR
SET RAIEN=+$ORDER(^RAMIS(71.3,"B",RAPROC,RAIEN))
if RAIEN'>0
QUIT
Begin DoDot:2
+10 SET RACNT=RACNT+1
if RACNT>1
DO SAVE
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 IF '$DATA(^TMP($JOB,"RA CMMN PROC"))
DO XIT
QUIT
+14 SET RA1=0
+15 ;file 71 ien
FOR
SET RA1=$ORDER(^TMP($JOB,"RA CMMN PROC",RA1))
if RA1'>0
QUIT
Begin DoDot:1
+16 SET RA2=""
SET RACNT=0
+17 ;active?
FOR
SET RA2=$ORDER(^TMP($JOB,"RA CMMN PROC",RA1,RA2))
if RA2']""
QUIT
Begin DoDot:2
+18 SET RA3=0
+19 ;71.3
FOR
SET RA3=$ORDER(^TMP($JOB,"RA CMMN PROC",RA1,RA2,RA3))
if RA3'>0
QUIT
Begin DoDot:3
+20 SET RACNT=RACNT+1
if RACNT>1
DO PURGE(RA3)
+21 QUIT
End DoDot:3
+22 QUIT
End DoDot:2
+23 QUIT
End DoDot:1
+24 ; re-sequence common procedures
DO RESEQ
XIT ; Kill variables and quit
+1 KILL RA1,RA2,RA3,RACNT,RAIEN,RAPROC,^TMP($JOB,"RA CMMN PROC")
+2 QUIT
PURGE(DA) ; Delete duplicate common procedures saving the first
+1 ; occurrence of our common in question. Data is stored so that active
+2 ; common procedures will sort first.
+3 ; Input: DA-ien of entry in 71.3 to be deleted!
+4 KILL %,DIC,DIK,X,Y
SET DIK="^RAMIS(71.3,"
DO ^DIK
KILL %,DIC,DIK,X,Y
+5 QUIT
SAVE ; Save off all common procedure data when more than one occurrence.
+1 KILL RA713,RACTIV
+2 IF RACNT=2
Begin DoDot:1
+3 NEW RAIEN
SET RAIEN=+$ORDER(^RAMIS(71.3,"B",RAPROC,0))
if 'RAIEN
QUIT
+4 SET RA713=$GET(^RAMIS(71.3,RAIEN,0))
if RA713']""
QUIT
+5 SET RACTIV=$SELECT($PIECE(RA713,"^",5)]"":1,1:0)
+6 DO SET
+7 QUIT
End DoDot:1
+8 SET RA713=$GET(^RAMIS(71.3,RAIEN,0))
if RA713']""
QUIT
+9 SET RACTIV=$SELECT($PIECE(RA713,"^",5)]"":1,1:0)
DO SET
+10 KILL RA713,RACTIV
+11 QUIT
SET ; Set the ^TMP($J,"RA CMMN PROC") global.
+1 ; RAPROC=pntr to file 71, RAIEN=ien in file 71.3
+2 ; RACTIV=Active flag: 1 for inactive, 0 for active
+3 SET ^TMP($JOB,"RA CMMN PROC",RAPROC,RACTIV,RAIEN)=""
+4 QUIT
RESEQ ;Resequence the common procedure list for all imaging types
+1 NEW D,DA,D0,DI,DIC,DIE,DQ,DR,RACNT,RAI,RAIMGTYI,RAJ,X,Y
+2 SET DIE="^RAMIS(71.3,"
SET RAIMGTYI=0
+3 FOR
SET RAIMGTYI=$ORDER(^RAMIS(71.3,"AA",RAIMGTYI))
if RAIMGTYI'>0
QUIT
Begin DoDot:1
+4 SET (RAI,RACNT)=0
+5 FOR
SET RAI=$ORDER(^RAMIS(71.3,"AA",RAIMGTYI,RAI))
if RAI'>0
QUIT
Begin DoDot:2
+6 SET RAJ=0
+7 FOR
SET RAJ=$ORDER(^RAMIS(71.3,"AA",RAIMGTYI,RAI,RAJ))
if RAJ'>0
QUIT
IF $DATA(^RAMIS(71.3,RAJ,0))
Begin DoDot:3
+8 SET DA=RAJ
SET RACNT=RACNT+1
+9 SET DR="3////^S X=RACNT"
DO ^DIE
+10 QUIT
End DoDot:3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
