RAUTL23 ;MANTECH/CLT - LOINC FOR THE HL7 UTILITY ; 28 Oct 2016 11:13 AM
;;5.0;Radiology/Nuclear Medicine;**127**;Mar 16, 1998;Build 119
EN ;MAIN ENTRY POINT
S RAMATCH=$P($G(^RAMIS(71,+$P(RACN0,"^",2),"NTRT")),U,1)
I $G(RAMATCH)'="" S RALOINC=$P($G(^RAMRPF(71.99,RAMATCH,0)),U,4)
Q
MTCH ;ALREADY MATCHED NOTIFICATION
S RAPLUSY=^XTMP("RAMAIN4",$J,Y)
MTCH1 ;ALTERNATE ENTRY POINT
S RAIEN="",RAIEN=$O(^RAMIS(71,"MRPF",RAPLUSY,RAIEN))
Q:$G(RAMATCH)="GO"
W !!?3,$C(7),"The MRPF procedure "_RAMATCH_" is already mapped to your procedure ",$P(^RAMIS(71,RAIEN,0),U,1)_"."
I RAMTCH=1 W !," Use the already created procedure.",!
;I RAMTCH=2 W !?3,"Either change "_$P(^RAMIS(71,RAIEN,0),U,1)_" or choose another MRPF.",!
I $G(RANEW)=1 W !!,"This new procedure will be removed." H 1
S ^XTMP("RAMAIN4",$J,"RAEND")=1 K RAMTCH
Q
SEED ;HAS FILE 71.99 BEEN SEEDED
W !!?3,"The populating of the MASTER RADIOLOGY PROCEDURE file is called seeding.",!
S DIE="^RAMRPF(71.98,",DA=1,DR="9//NO" D ^DIE
Q
ONE ;EDIT MAPPING ON A SINGLE PROCEDURE
N A,RACPTMR,RAPRDA,DA,DR,DIR,DIE,DIC,OK,RAPRNM,RAMRPFNM,RAMRPFDA,RAXX
S (A,RACPTMR)=""
S DIC="^RAMIS(71,",DIC(0)="AEQM",DIC("A")="ENTER THE PROCEDURE TO BE EDITED:"
D ^DIC I +Y'>0 G ONEQT
S DA=+Y,(A,RACPTMR,RAPRDA)="",RAPRDA=DA,RAPRNM=$$GET1^DIQ(71,DA_",",.01)
; inactive check
S A=$$GET1^DIQ(71,DA_",",100,"I") I A'="" W !!,"This procedure is inactive" D ONEQT G ONE
; check for CPT code
S RACPTMR=$$GET1^DIQ(71,DA_",",9,"E") I RACPTMR="" W !!,"This procedure is not associated to a CPT Code." D ONEQT G ONE
; check if associated to MRPF
S A=$$GET1^DIQ(71,DA_",",900,"I") I A'="" S RAXX=$$GET1^DIQ(71.99,A_",",.01) W !!,"This procedure is already mapped to "_RAXX_"." D ONEQT G ONE
; CPT code not in MRPF
S A=$O(^RAMRPF(71.99,"C",RACPTMR,0)) I 'A W !!,"There are not any MRPF entries associated to CPT Code: "_RACPTMR D ONEQT G ONE
; check if all affiliated MRPFs are in use
S A=0,OK=0 F S A=$O(^RAMRPF(71.99,"C",RACPTMR,A)) Q:'A D I OK=1 Q
. S B=$O(^RAMIS(71,"MRPF",A,""))
. I B'="" Q
. S OK=1 Q
I 'OK W !!,"All MRPF Terms for this CPT Code ("_RACPTMR_") are allocated to other Procedures" D ONEQT G ONE
; select MRPF for procedure
K DIR,DIRUT,DA,Y
S DIR("S")="I '$$SCREEN^XTID(71.99,"""",(+Y_"",""))&($$ONECHK^RAUTL23(+Y)=1)&($$ONECK2^RAUTL23(+Y)=1)"
S DIR(0)="PO^71.99:EQZ"
S DIR("A")="Enter the MRPF to Associate with the Selected Procedure"
S DIR("?")="Enter the MRPF that you want to associate to the Procedure. Or, enter a '?' to view available choices for the Procedures CPT"
D ^DIR ; I $D(DIRUT) G ONEQT
I Y="^"!(X="^") G ONEQT
I +Y'>0 W !,"Nothing Selected" D ONEQT G ONE
N DA,DIE,DR
S A=$G(^RAMRPF(71.99,+Y,0)),A=$P(A,"^",4),RAMRPFDA=+Y
S DA=RAPRDA,DIE="^RAMIS(71,",DR="900///"_RAMRPFDA_";903///"_A D ^DIE
S RAMRPFNM=$$GET1^DIQ(71.99,RAMRPFDA_",",.01)
K DA,DIE,DR
W !!,"Procedure "_RAPRNM_" is now associated to MRPF "_RAMRPFNM
W !! D ONEQT G ONE
Q
;
ONEQT ; quit from one
K A,RACPTMR,RAPRDA,DA,DR,DIR,DIE,DIC,OK,RAPRNM,RAMRPFNM,RAMRPFDA,RAXX
Q
;
ONECHK(A) ; check if MRPF has same CPT code
I 'A Q 0
N B S B=$G(^RAMRPF(71.99,A,0)),B=$P(B,"^",3)
I B'=RACPTMR K B Q 0
K B Q 1
;
ONECK2(A) ; check if other 71 procedure is using MRPF item
I 'A Q 0
N B S B=""
S B=$O(^RAMIS(71,"MRPF",A,B))
I B K B Q 0
K B Q 1
;
LOINC ;ENTER/EDIT LOINC FOR ONE ENTRY IN FILE 71
N DIC,DIE,X,Y
S DIC="^RAMIS(71,",DIC(0)="AEQM" D ^DIC Q:Y'>0 S DA=+Y
S DIE=DIC,DR=903 D ^DIE
Q
ACTIVE ;IS THE MRPF ENTRY ACTIVE
N RA99,I99,I999 S I99=0 F S I99=$O(^RAMRPF(71.99,RAPROIEN,"TERMSTATUS","B",I99)) Q:I99="" D
. S I999="",I999=$O(^RAMRPF(71.99,RAPROIEN,"TERMSTATUS","B",I99,I999))
. I $P(^RAMRPF(71.99,RAPROIEN,"TERMSTATUS",I999,0),U,1)<DT S RA99=$S($P(^(0),U,2)=1:"ACTIVE",1:"INACTIVE")
. Q
Q $G(RA99)
CPT(DA,RAX) ;Ask for CPT Code when the 'Procedure Enter/Edit' option
;is exercised. Called from input template: RA PROCEDURE EDIT
;Input: DA=ien of new record being edited & RAX=procedure name
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,RAFDA,RAYN,X,Y S RAYN=0
F D Q:+RAYN!($D(DIRUT)#2)
.K X,Y S DIR(0)="71,9" D ^DIR Q:$D(DIRUT)#2
.;Y=N^S where N=record ien & S=.01 value of the record
.W !!,"Note: If an erroneous CPT Code is accepted it cannot be changed; the",!,"procedure must be inactivated."
.W !!,"Are you adding '"_$P(Y,U,2)_"' as the CPT Code for the new Rad/Nuc Med Procedure",!,"'"_RAX_"'? NO// "
. S DIR(0)="Y",DIR("B")="NO",DIR("A",1)="Are you adding '"_+Y_"' as the CPT Code for the new RAD/NUC MED PROCEDURE",DIR("A")=RAX D ^DIR
. D ^DIR
.;R RAYN:DTIME
.;I '$T!(RAYN["^") S RAYN=-1 Q
.;S RAYN=$E(RAYN) S:RAYN="" RAYN="N"
.I "YyNn"'[X W !?3,"Enter 'Y' to accept the CPT Code, or 'N' to reject the CPT Code or '^' to",!?3,"exit without selecting a CPT Code."
.I W !?5,"Note: If an erroneous CPT Code is accepted it cannot be changed; the",!?5,"procedure must be inactivated."
.S:"Yy"[X RAYN="1^Y"
.S:"Nn"[X RAYN=0
.Q
I $P(RAYN,U,2)="Y" S RAFDA(71,DA_",",9)=$P(Y,U) D FILE^DIE("","RAFDA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL23 5104 printed Dec 13, 2024@02:40:27 Page 2
RAUTL23 ;MANTECH/CLT - LOINC FOR THE HL7 UTILITY ; 28 Oct 2016 11:13 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**127**;Mar 16, 1998;Build 119
EN ;MAIN ENTRY POINT
+1 SET RAMATCH=$PIECE($GET(^RAMIS(71,+$PIECE(RACN0,"^",2),"NTRT")),U,1)
+2 IF $GET(RAMATCH)'=""
SET RALOINC=$PIECE($GET(^RAMRPF(71.99,RAMATCH,0)),U,4)
+3 QUIT
MTCH ;ALREADY MATCHED NOTIFICATION
+1 SET RAPLUSY=^XTMP("RAMAIN4",$JOB,Y)
MTCH1 ;ALTERNATE ENTRY POINT
+1 SET RAIEN=""
SET RAIEN=$ORDER(^RAMIS(71,"MRPF",RAPLUSY,RAIEN))
+2 if $GET(RAMATCH)="GO"
QUIT
+3 WRITE !!?3,$CHAR(7),"The MRPF procedure "_RAMATCH_" is already mapped to your procedure ",$PIECE(^RAMIS(71,RAIEN,0),U,1)_"."
+4 IF RAMTCH=1
WRITE !," Use the already created procedure.",!
+5 ;I RAMTCH=2 W !?3,"Either change "_$P(^RAMIS(71,RAIEN,0),U,1)_" or choose another MRPF.",!
+6 IF $GET(RANEW)=1
WRITE !!,"This new procedure will be removed."
HANG 1
+7 SET ^XTMP("RAMAIN4",$JOB,"RAEND")=1
KILL RAMTCH
+8 QUIT
SEED ;HAS FILE 71.99 BEEN SEEDED
+1 WRITE !!?3,"The populating of the MASTER RADIOLOGY PROCEDURE file is called seeding.",!
+2 SET DIE="^RAMRPF(71.98,"
SET DA=1
SET DR="9//NO"
DO ^DIE
+3 QUIT
ONE ;EDIT MAPPING ON A SINGLE PROCEDURE
+1 NEW A,RACPTMR,RAPRDA,DA,DR,DIR,DIE,DIC,OK,RAPRNM,RAMRPFNM,RAMRPFDA,RAXX
+2 SET (A,RACPTMR)=""
+3 SET DIC="^RAMIS(71,"
SET DIC(0)="AEQM"
SET DIC("A")="ENTER THE PROCEDURE TO BE EDITED:"
+4 DO ^DIC
IF +Y'>0
GOTO ONEQT
+5 SET DA=+Y
SET (A,RACPTMR,RAPRDA)=""
SET RAPRDA=DA
SET RAPRNM=$$GET1^DIQ(71,DA_",",.01)
+6 ; inactive check
+7 SET A=$$GET1^DIQ(71,DA_",",100,"I")
IF A'=""
WRITE !!,"This procedure is inactive"
DO ONEQT
GOTO ONE
+8 ; check for CPT code
+9 SET RACPTMR=$$GET1^DIQ(71,DA_",",9,"E")
IF RACPTMR=""
WRITE !!,"This procedure is not associated to a CPT Code."
DO ONEQT
GOTO ONE
+10 ; check if associated to MRPF
+11 SET A=$$GET1^DIQ(71,DA_",",900,"I")
IF A'=""
SET RAXX=$$GET1^DIQ(71.99,A_",",.01)
WRITE !!,"This procedure is already mapped to "_RAXX_"."
DO ONEQT
GOTO ONE
+12 ; CPT code not in MRPF
+13 SET A=$ORDER(^RAMRPF(71.99,"C",RACPTMR,0))
IF 'A
WRITE !!,"There are not any MRPF entries associated to CPT Code: "_RACPTMR
DO ONEQT
GOTO ONE
+14 ; check if all affiliated MRPFs are in use
+15 SET A=0
SET OK=0
FOR
SET A=$ORDER(^RAMRPF(71.99,"C",RACPTMR,A))
if 'A
QUIT
Begin DoDot:1
+16 SET B=$ORDER(^RAMIS(71,"MRPF",A,""))
+17 IF B'=""
QUIT
+18 SET OK=1
QUIT
End DoDot:1
IF OK=1
QUIT
+19 IF 'OK
WRITE !!,"All MRPF Terms for this CPT Code ("_RACPTMR_") are allocated to other Procedures"
DO ONEQT
GOTO ONE
+20 ; select MRPF for procedure
+21 KILL DIR,DIRUT,DA,Y
+22 SET DIR("S")="I '$$SCREEN^XTID(71.99,"""",(+Y_"",""))&($$ONECHK^RAUTL23(+Y)=1)&($$ONECK2^RAUTL23(+Y)=1)"
+23 SET DIR(0)="PO^71.99:EQZ"
+24 SET DIR("A")="Enter the MRPF to Associate with the Selected Procedure"
+25 SET DIR("?")="Enter the MRPF that you want to associate to the Procedure. Or, enter a '?' to view available choices for the Procedures CPT"
+26 ; I $D(DIRUT) G ONEQT
DO ^DIR
+27 IF Y="^"!(X="^")
GOTO ONEQT
+28 IF +Y'>0
WRITE !,"Nothing Selected"
DO ONEQT
GOTO ONE
+29 NEW DA,DIE,DR
+30 SET A=$GET(^RAMRPF(71.99,+Y,0))
SET A=$PIECE(A,"^",4)
SET RAMRPFDA=+Y
+31 SET DA=RAPRDA
SET DIE="^RAMIS(71,"
SET DR="900///"_RAMRPFDA_";903///"_A
DO ^DIE
+32 SET RAMRPFNM=$$GET1^DIQ(71.99,RAMRPFDA_",",.01)
+33 KILL DA,DIE,DR
+34 WRITE !!,"Procedure "_RAPRNM_" is now associated to MRPF "_RAMRPFNM
+35 WRITE !!
DO ONEQT
GOTO ONE
+36 QUIT
+37 ;
ONEQT ; quit from one
+1 KILL A,RACPTMR,RAPRDA,DA,DR,DIR,DIE,DIC,OK,RAPRNM,RAMRPFNM,RAMRPFDA,RAXX
+2 QUIT
+3 ;
ONECHK(A) ; check if MRPF has same CPT code
+1 IF 'A
QUIT 0
+2 NEW B
SET B=$GET(^RAMRPF(71.99,A,0))
SET B=$PIECE(B,"^",3)
+3 IF B'=RACPTMR
KILL B
QUIT 0
+4 KILL B
QUIT 1
+5 ;
ONECK2(A) ; check if other 71 procedure is using MRPF item
+1 IF 'A
QUIT 0
+2 NEW B
SET B=""
+3 SET B=$ORDER(^RAMIS(71,"MRPF",A,B))
+4 IF B
KILL B
QUIT 0
+5 KILL B
QUIT 1
+6 ;
LOINC ;ENTER/EDIT LOINC FOR ONE ENTRY IN FILE 71
+1 NEW DIC,DIE,X,Y
+2 SET DIC="^RAMIS(71,"
SET DIC(0)="AEQM"
DO ^DIC
if Y'>0
QUIT
SET DA=+Y
+3 SET DIE=DIC
SET DR=903
DO ^DIE
+4 QUIT
ACTIVE ;IS THE MRPF ENTRY ACTIVE
+1 NEW RA99,I99,I999
SET I99=0
FOR
SET I99=$ORDER(^RAMRPF(71.99,RAPROIEN,"TERMSTATUS","B",I99))
if I99=""
QUIT
Begin DoDot:1
+2 SET I999=""
SET I999=$ORDER(^RAMRPF(71.99,RAPROIEN,"TERMSTATUS","B",I99,I999))
+3 IF $PIECE(^RAMRPF(71.99,RAPROIEN,"TERMSTATUS",I999,0),U,1)<DT
SET RA99=$SELECT($PIECE(^(0),U,2)=1:"ACTIVE",1:"INACTIVE")
+4 QUIT
End DoDot:1
+5 QUIT $GET(RA99)
CPT(DA,RAX) ;Ask for CPT Code when the 'Procedure Enter/Edit' option
+1 ;is exercised. Called from input template: RA PROCEDURE EDIT
+2 ;Input: DA=ien of new record being edited & RAX=procedure name
+3 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,RAFDA,RAYN,X,Y
SET RAYN=0
+4 FOR
Begin DoDot:1
+5 KILL X,Y
SET DIR(0)="71,9"
DO ^DIR
if $DATA(DIRUT)#2
QUIT
+6 ;Y=N^S where N=record ien & S=.01 value of the record
+7 WRITE !!,"Note: If an erroneous CPT Code is accepted it cannot be changed; the",!,"procedure must be inactivated."
+8 WRITE !!,"Are you adding '"_$PIECE(Y,U,2)_"' as the CPT Code for the new Rad/Nuc Med Procedure",!,"'"_RAX_"'? NO// "
+9 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A",1)="Are you adding '"_+Y_"' as the CPT Code for the new RAD/NUC MED PROCEDURE"
SET DIR("A")=RAX
DO ^DIR
+10 DO ^DIR
+11 ;R RAYN:DTIME
+12 ;I '$T!(RAYN["^") S RAYN=-1 Q
+13 ;S RAYN=$E(RAYN) S:RAYN="" RAYN="N"
+14 IF "YyNn"'[X
WRITE !?3,"Enter 'Y' to accept the CPT Code, or 'N' to reject the CPT Code or '^' to",!?3,"exit without selecting a CPT Code."
+15 IF $TEST
WRITE !?5,"Note: If an erroneous CPT Code is accepted it cannot be changed; the",!?5,"procedure must be inactivated."
+16 if "Yy"[X
SET RAYN="1^Y"
+17 if "Nn"[X
SET RAYN=0
+18 QUIT
End DoDot:1
if +RAYN!($DATA(DIRUT)#2)
QUIT
+19 IF $PIECE(RAYN,U,2)="Y"
SET RAFDA(71,DA_",",9)=$PIECE(Y,U)
DO FILE^DIE("","RAFDA")
+20 QUIT
