RAMRPIN ;BPFO/CLT - LIST ACTVE PROCEDURES WITH INACTIVE MRPF ; 12 Sep 2016 2:17 PM
;;5.0;Radiology/Nuclear Medicine;**127**;Mar 16, 1998;Build 119
;
; This routine uses the following IA's:
; #1995 - CPT calls (supported)
EN ;PRIMARY ENTRY POINT
N RAMRPF,RAIEN,%ZIS
G TASK
LOOK ;BEGIN LOOKING FOR ACTIVE PROCEDURES WITH INACTIVE CPT OR MRPF
N RAMRPF,RAIEN,RADT,RACPT,RANAME,RATS,PAGE,RARTN,MRPFNM,RACINF S PAGE=0 K ^XTMP("RAMRPIN",$J)
S RANAME="" F S RANAME=$O(^RAMIS(71,"B",RANAME)) Q:RANAME="" S RAIEN=$O(^RAMIS(71,"B",RANAME,"")) D:$G(RAIEN)'=""
. I $G(^RAMIS(71,RAIEN,0))="" Q
. I $P(^RAMIS(71,RAIEN,0),U,6)'="D" Q
. I $G(^RAMIS(71,RAIEN,"I"))'="",^RAMIS(71,RAIEN,"I")<DT Q
. I $P($G(^RAMIS(71,RAIEN,0)),U,9)="" Q
. S RACPT=$P(^RAMIS(71,RAIEN,0),U,9)
. S RAMRPF=$P($G(^RAMIS(71,RAIEN,"NTRT")),U,1)
. ; piece 7 is 1 if active
. ;I $P(^ICPT(RACPT,0),U,4)=1 D
. S RACINF=$$CPT^ICPTCOD(RACPT),RACINF=$S($P(RACINF,U,7)>0:0,1:1) I +RACINF=1 D
.. I +RACINF'=1 Q
.. ;I $P(^ICPT(RACPT,0),U,4)'=1 Q
.. S RACINF=$$CPT^ICPTCOD(RACPT)
.. ;S ^XTMP("RAMRPIN",$J,RANAME,1)=RACPT_U_$P($G(^ICPT(RACPT,0)),U,7)
.. S ^XTMP("RAMRPIN",$J,RANAME,1)=RACPT_U_$P(RACINF,"^",8)
.. Q
. I $G(RAMRPF)'="" S RATS=$P($G(^RAMRPF(71.99,RAMRPF,"TERMSTATUS",0)),U,3) D:RATS'="" Q
.. I $P($G(^RAMRPF(71.99,RAMRPF,"TERMSTATUS",RATS,0)),U,2)=0 D
... S ^XTMP("RAMRPIN",$J,$P(^RAMIS(71,RAIEN,0),U,1),1)=$P(^RAMRPF(71.99,RAMRPF,0),U,1)_U_$P(^RAMRPF(71.99,RAMRPF,"TERMSTATUS",RATS,0),U,1)
... Q
.. Q
. Q
I $D(^XTMP("RAMRPIN",$J)) S ^XTMP("RAMRPIN",$J,0)=DT_U_DT
PRNT ;PRINT THE FOUND DATA
D HDR
I '$D(^XTMP("RAMRPIN",$J)) D
. W !!,"There are no active procedures with inactive CPT code or inactive",!,"Master Radiology Procedure File (MRPF) entry.",!
. Q
S RANAME="" F S RANAME=$O(^XTMP("RAMRPIN",$J,RANAME)) Q:RANAME=""!(RARTN["^") G:RARTN["^" END D:RARTN'["^"
. Q:$G(RARTN)["^"
. I $G(^XTMP("RAMRPIN",$J,RANAME,1))'="" D
.. D:$Y>(IOSL-4) HDR S RACPT=$P(^XTMP("RAMRPIN",$J,RANAME,1),U,1) Q:RACPT'?1.N
.. W !,$E(RANAME,1,20)
.. ;S:$G(RACPT)'="" RACPT=$P(^ICPT(RACPT,0),U,1) W ?22,RACPT
.. S:$G(RACPT)'="" RACINF=$$CPT^ICPTCOD(RACPT),RACPT=$P(RACINF,"^",2) W ?22,RACPT
.. W ?32,$$FMTE^XLFDT($P(^XTMP("RAMRPIN",$J,RANAME,1),U,2),"2M")
.. Q
. I $G(^XTMP("RAMRPIN",$J,RANAME,1))'="" D
.. Q:$P(^XTMP("RAMRPIN",$J,RANAME,1),U,1)?1.N
.. S MRPFNM=$P(^XTMP("RAMRPIN",$J,RANAME,1),U,1)
.. D:$Y>(IOSL-4) HDR W !,$E(RANAME,1,20)
.. W ?45,$E(MRPFNM,1,20),?67,$$FMTE^XLFDT($P(^XTMP("RAMRPIN",$J,RANAME,1),U,2),"2M")
.. Q
. Q
G END
TASK ;ASK DEVICE AND QUEUE
S %ZIS("A")="QUEUE ON DEVICE(80 COLUMN): ",%ZIS("B")="HOME"
D ^%ZIS I IOST["C-" G LOOK
S ZTRTN="RATIMBUL",ZTDESC="Radiology new procedure time bulletin"
S ZTRTN="LOOK^RAMRPIN",ZTDESC="Active Radiology procedures with inactive CPT or MRPF."
D ^ZTLOAD
K ZTSK,ZTRTN,ZTDESC,ZTDTH,X1,X2,X
Q
END ;END THE ROUTINE
K RACINF
K ^XTMP("RAMRPIN",$J)
Q
HDR ;NEW PAGE AND PRINT HEADER
S:$G(PAGE)="" PAGE=0
I $G(RARTN)["^" W @IOF Q
I IOST["C-" R !?3,"Enter <RETURN> to continue or '^' to quit:",RARTN:300
I $G(RARTN)["^" W @IOF Q
S PAGE=PAGE+1 W @IOF,!!?27,"ACTIVE RADIOLOGY PROCEDURES",?70,"PAGE ",PAGE
W !?33,"WITH INACTIVE"
W !?29,"CPT CODE OR MRPF LOINC"
W !!?3,"PROCEDURE NAME",?22,"CPT CODE",?32,"INAC DT",?45,"MRPF NAME",?67,"INAC DT"
W !,"====================",?22,"========",?32,"=======",?45,"====================",?67,"======="
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAMRPIN 3487 printed Sep 23, 2025@20:13:30 Page 2
RAMRPIN ;BPFO/CLT - LIST ACTVE PROCEDURES WITH INACTIVE MRPF ; 12 Sep 2016 2:17 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**127**;Mar 16, 1998;Build 119
+2 ;
+3 ; This routine uses the following IA's:
+4 ; #1995 - CPT calls (supported)
EN ;PRIMARY ENTRY POINT
+1 NEW RAMRPF,RAIEN,%ZIS
+2 GOTO TASK
LOOK ;BEGIN LOOKING FOR ACTIVE PROCEDURES WITH INACTIVE CPT OR MRPF
+1 NEW RAMRPF,RAIEN,RADT,RACPT,RANAME,RATS,PAGE,RARTN,MRPFNM,RACINF
SET PAGE=0
KILL ^XTMP("RAMRPIN",$JOB)
+2 SET RANAME=""
FOR
SET RANAME=$ORDER(^RAMIS(71,"B",RANAME))
if RANAME=""
QUIT
SET RAIEN=$ORDER(^RAMIS(71,"B",RANAME,""))
if $GET(RAIEN)'=""
Begin DoDot:1
+3 IF $GET(^RAMIS(71,RAIEN,0))=""
QUIT
+4 IF $PIECE(^RAMIS(71,RAIEN,0),U,6)'="D"
QUIT
+5 IF $GET(^RAMIS(71,RAIEN,"I"))'=""
IF ^RAMIS(71,RAIEN,"I")<DT
QUIT
+6 IF $PIECE($GET(^RAMIS(71,RAIEN,0)),U,9)=""
QUIT
+7 SET RACPT=$PIECE(^RAMIS(71,RAIEN,0),U,9)
+8 SET RAMRPF=$PIECE($GET(^RAMIS(71,RAIEN,"NTRT")),U,1)
+9 ; piece 7 is 1 if active
+10 ;I $P(^ICPT(RACPT,0),U,4)=1 D
+11 SET RACINF=$$CPT^ICPTCOD(RACPT)
SET RACINF=$SELECT($PIECE(RACINF,U,7)>0:0,1:1)
IF +RACINF=1
Begin DoDot:2
+12 IF +RACINF'=1
QUIT
+13 ;I $P(^ICPT(RACPT,0),U,4)'=1 Q
+14 SET RACINF=$$CPT^ICPTCOD(RACPT)
+15 ;S ^XTMP("RAMRPIN",$J,RANAME,1)=RACPT_U_$P($G(^ICPT(RACPT,0)),U,7)
+16 SET ^XTMP("RAMRPIN",$JOB,RANAME,1)=RACPT_U_$PIECE(RACINF,"^",8)
+17 QUIT
End DoDot:2
+18 IF $GET(RAMRPF)'=""
SET RATS=$PIECE($GET(^RAMRPF(71.99,RAMRPF,"TERMSTATUS",0)),U,3)
if RATS'=""
Begin DoDot:2
+19 IF $PIECE($GET(^RAMRPF(71.99,RAMRPF,"TERMSTATUS",RATS,0)),U,2)=0
Begin DoDot:3
+20 SET ^XTMP("RAMRPIN",$JOB,$PIECE(^RAMIS(71,RAIEN,0),U,1),1)=$PIECE(^RAMRPF(71.99,RAMRPF,0),U,1)_U_$PIECE(^RAMRPF(71.99,RAMRPF,"TERMSTATUS",RATS,0),U,1)
+21 QUIT
End DoDot:3
+22 QUIT
End DoDot:2
QUIT
+23 QUIT
End DoDot:1
+24 IF $DATA(^XTMP("RAMRPIN",$JOB))
SET ^XTMP("RAMRPIN",$JOB,0)=DT_U_DT
PRNT ;PRINT THE FOUND DATA
+1 DO HDR
+2 IF '$DATA(^XTMP("RAMRPIN",$JOB))
Begin DoDot:1
+3 WRITE !!,"There are no active procedures with inactive CPT code or inactive",!,"Master Radiology Procedure File (MRPF) entry.",!
+4 QUIT
End DoDot:1
+5 SET RANAME=""
FOR
SET RANAME=$ORDER(^XTMP("RAMRPIN",$JOB,RANAME))
if RANAME=""!(RARTN["^")
QUIT
if RARTN["^"
GOTO END
if RARTN'["^"
Begin DoDot:1
+6 if $GET(RARTN)["^"
QUIT
+7 IF $GET(^XTMP("RAMRPIN",$JOB,RANAME,1))'=""
Begin DoDot:2
+8 if $Y>(IOSL-4)
DO HDR
SET RACPT=$PIECE(^XTMP("RAMRPIN",$JOB,RANAME,1),U,1)
if RACPT'?1.N
QUIT
+9 WRITE !,$EXTRACT(RANAME,1,20)
+10 ;S:$G(RACPT)'="" RACPT=$P(^ICPT(RACPT,0),U,1) W ?22,RACPT
+11 if $GET(RACPT)'=""
SET RACINF=$$CPT^ICPTCOD(RACPT)
SET RACPT=$PIECE(RACINF,"^",2)
WRITE ?22,RACPT
+12 WRITE ?32,$$FMTE^XLFDT($PIECE(^XTMP("RAMRPIN",$JOB,RANAME,1),U,2),"2M")
+13 QUIT
End DoDot:2
+14 IF $GET(^XTMP("RAMRPIN",$JOB,RANAME,1))'=""
Begin DoDot:2
+15 if $PIECE(^XTMP("RAMRPIN",$JOB,RANAME,1),U,1)?1.N
QUIT
+16 SET MRPFNM=$PIECE(^XTMP("RAMRPIN",$JOB,RANAME,1),U,1)
+17 if $Y>(IOSL-4)
DO HDR
WRITE !,$EXTRACT(RANAME,1,20)
+18 WRITE ?45,$EXTRACT(MRPFNM,1,20),?67,$$FMTE^XLFDT($PIECE(^XTMP("RAMRPIN",$JOB,RANAME,1),U,2),"2M")
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 GOTO END
TASK ;ASK DEVICE AND QUEUE
+1 SET %ZIS("A")="QUEUE ON DEVICE(80 COLUMN): "
SET %ZIS("B")="HOME"
+2 DO ^%ZIS
IF IOST["C-"
GOTO LOOK
+3 SET ZTRTN="RATIMBUL"
SET ZTDESC="Radiology new procedure time bulletin"
+4 SET ZTRTN="LOOK^RAMRPIN"
SET ZTDESC="Active Radiology procedures with inactive CPT or MRPF."
+5 DO ^ZTLOAD
+6 KILL ZTSK,ZTRTN,ZTDESC,ZTDTH,X1,X2,X
+7 QUIT
END ;END THE ROUTINE
+1 KILL RACINF
+2 KILL ^XTMP("RAMRPIN",$JOB)
+3 QUIT
HDR ;NEW PAGE AND PRINT HEADER
+1 if $GET(PAGE)=""
SET PAGE=0
+2 IF $GET(RARTN)["^"
WRITE @IOF
QUIT
+3 IF IOST["C-"
READ !?3,"Enter <RETURN> to continue or '^' to quit:",RARTN:300
+4 IF $GET(RARTN)["^"
WRITE @IOF
QUIT
+5 SET PAGE=PAGE+1
WRITE @IOF,!!?27,"ACTIVE RADIOLOGY PROCEDURES",?70,"PAGE ",PAGE
+6 WRITE !?33,"WITH INACTIVE"
+7 WRITE !?29,"CPT CODE OR MRPF LOINC"
+8 WRITE !!?3,"PROCEDURE NAME",?22,"CPT CODE",?32,"INAC DT",?45,"MRPF NAME",?67,"INAC DT"
+9 WRITE !,"====================",?22,"========",?32,"=======",?45,"====================",?67,"======="
+10 QUIT
