RANPROU2 ;MANTECH/CLT - LOINC FOR THE HL7 UTILITY ; 28 Oct 2016 10:36 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))
S RAMATCH=$S($G(RAIEN)'="":"QUIT",1:"GO")
I $G(RAMATCH)="GO" S RAMV=1 Q
W !!?3,$C(7),"The MRPF procedure "_$P(^RAMRPF(71.99,RAPROIEN,0),U,1)_" 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 RAMTCH=2 W !,?3," Choose another MRPF.",!
I $G(RANEW)=1 W !!,"This new procedure will be removed." H 1 D
. ;S DIK="^RAMRPF(71.11,",DA=1 D ^DIK K ^RAMRPF(71.11,"CREAT",DT,DA)
. I $G(RA7111DA)="" S RA7111DA=$G(^TMP("RA7111DA",$J))
. I RA7111DA>0 D
. . S DIK="^RAMRPF(71.11,",DA=RA7111DA D ^DIK K ^RAMRPF(71.11,"CREAT",DT,DA)
. . K ^TMP("RA7111DA",$J)
. S ^XTMP("RAMAIN4",$J,"RAEND")=1,RANQUIT=1 K RAMTCHS S RAMV=0
. Q
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
G ONE^RAUTL23
S DIC="^RAMIS(71,",DIC(0)="AEQM",DIC("A")="ENTER THE PROCEDURE TO BE EDITED:"
D ^DIC Q:Y'>0
S DIE=DIC,DA=+Y,DR="900" D ^DIE
S RAPLUSY=$P($G(^RAMIS(71,DA,"NTRT")),U,1) Q:RAPLUSY=""
S RAIEN="",RAIEN=$O(^RAMIS(71,"MRPF",RAPLUSY,RAIEN))
I $G(RAIEN)'="",$G(RAIEN)'=DA S RAMTCH=2 D G ONE
. S RAMATCH=$P(^RAMRPF(71.99,RAPLUSY,0),U,1) D MTCH1
. S DR="900///@" D ^DIE
. Q
W !! G ONE
Q
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[HRANPROU2 3605 printed Oct 16, 2024@18:38:13 Page 2
RANPROU2 ;MANTECH/CLT - LOINC FOR THE HL7 UTILITY ; 28 Oct 2016 10:36 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 SET RAMATCH=$SELECT($GET(RAIEN)'="":"QUIT",1:"GO")
+3 IF $GET(RAMATCH)="GO"
SET RAMV=1
QUIT
+4 WRITE !!?3,$CHAR(7),"The MRPF procedure "_$PIECE(^RAMRPF(71.99,RAPROIEN,0),U,1)_" is already mapped to your procedure ",$PIECE(^RAMIS(71,RAIEN,0),U,1)_"."
+5 IF RAMTCH=1
WRITE !," Use the already created procedure.",!
+6 ;I RAMTCH=2 W !?3,"Either change "_$P(^RAMIS(71,RAIEN,0),U,1)_" or choose another MRPF.",!
+7 ;I RAMTCH=2 W !,?3," Choose another MRPF.",!
+8 IF $GET(RANEW)=1
WRITE !!,"This new procedure will be removed."
HANG 1
Begin DoDot:1
+9 ;S DIK="^RAMRPF(71.11,",DA=1 D ^DIK K ^RAMRPF(71.11,"CREAT",DT,DA)
+10 IF $GET(RA7111DA)=""
SET RA7111DA=$GET(^TMP("RA7111DA",$JOB))
+11 IF RA7111DA>0
Begin DoDot:2
+12 SET DIK="^RAMRPF(71.11,"
SET DA=RA7111DA
DO ^DIK
KILL ^RAMRPF(71.11,"CREAT",DT,DA)
+13 KILL ^TMP("RA7111DA",$JOB)
End DoDot:2
+14 SET ^XTMP("RAMAIN4",$JOB,"RAEND")=1
SET RANQUIT=1
KILL RAMTCHS
SET RAMV=0
+15 QUIT
End DoDot:1
+16 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 GOTO ONE^RAUTL23
+2 SET DIC="^RAMIS(71,"
SET DIC(0)="AEQM"
SET DIC("A")="ENTER THE PROCEDURE TO BE EDITED:"
+3 DO ^DIC
if Y'>0
QUIT
+4 SET DIE=DIC
SET DA=+Y
SET DR="900"
DO ^DIE
+5 SET RAPLUSY=$PIECE($GET(^RAMIS(71,DA,"NTRT")),U,1)
if RAPLUSY=""
QUIT
+6 SET RAIEN=""
SET RAIEN=$ORDER(^RAMIS(71,"MRPF",RAPLUSY,RAIEN))
+7 IF $GET(RAIEN)'=""
IF $GET(RAIEN)'=DA
SET RAMTCH=2
Begin DoDot:1
+8 SET RAMATCH=$PIECE(^RAMRPF(71.99,RAPLUSY,0),U,1)
DO MTCH1
+9 SET DR="900///@"
DO ^DIE
+10 QUIT
End DoDot:1
GOTO ONE
+11 WRITE !!
GOTO ONE
+12 QUIT
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
