- 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
- 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