LRCAPPH4 ;DALOI/RSH/FHS-PRINT CPT CODES ;1-OCT-1998
;;5.2;LAB SERVICE;**263**;Sep 27,1994
EN ;
N LREND
S LREND=1
W @IOF,!!,$$CJ^XLFSTR("This option will print CPT CODE that have inactive",IOM)
W !,$$CJ^XLFSTR("date in the WKLD CODE(#64) ONLY",IOM)
W !!,$$CJ^XLFSTR("It DOES NOT provide a inactive CPT code list from",IOM)
W !,$$CJ^XLFSTR("the CPT (#81) file. ",IOM)
ASK ;
K DIR S DIR(0)="SO^1:Ready to print INACTIVE CPT CODES REPORT;2:Abort"
D ^DIR K DIR
I $S($G(DIRUT):1,$G(DUOUT):1,$G(DTOUT):1,Y=2:1,1:0) G END
K %ZIS S %ZIS="Q" D ^%ZIS
G END:POP
I $G(IO("Q")) D G END
. S ZTRTN="ACTIVE^LRCAPPH4",(LRION,ZTIO)=ION,ZTDESC="Print INVALID CPT CODE" D ^%ZTLOAD
. D ^%ZISC
. W:$D(ZTSK)'[0 !!?5," Tasked to Print on : ",LRION H 5
. K LRION
D ACTIVE
Q
ACTIVE ;Search ^LAM( and find INVALID CPT CODES
S LRACT=1,LREND=0
D EN^LRCAPPH3
W !
Q:$G(LREND)
D DQ("^TMP(""LRCAPPH"","_$J)
Q
DQ(LRNX) ;
; LRNODE= subscripted data storage array root
; ie ^TMP("LRCAPPH",$J OR X("LR"
; ^TMP("LRCAPPH",$J,0)="KERNEL DELETE DATE^REPORT DATE^REPORT NAME"
N LREND
S:$D(ZTQUEUED) ZTREQ="@" S LRPDT=$$FMTE^XLFDT($$NOW^XLFDT,"1P")
S (LRPAGE,LREND)=0,$P(LRLINE,"=",(IOM-1))=""
S LRNXL=$L(LRNX),LRNODE=LRNX
I $E(LRNODE,$L(LRNX))'="(",$E(LRNODE,$L(LRNX))'="," S LRNODE=LRNX_","
I $E(LRNODE,$L(LRNODE))'=")" S LRNODE=LRNODE_"0)"
Q:$S('$L($P(LRNODE,"(")):1,$E(LRNODE,$L(LRNODE))'=")":1,1:0)
S LRPTNM="Data listing of "_LRNODE
IO U IO
I $D(@LRNODE)#2 D
. S LRREC=$G(@LRNODE)
. S:$L($P(LRREC,U,3)) LRPTNM=$P(LRREC,U,3)
. S LRPDT=$P(LRREC,U,2)
. S:LRPDT LRPDT=$$FMTE^XLFDT(LRPDT,"1P")
. W !
. D HDR
F S LRNODE=$Q(@LRNODE) Q:$E(LRNODE,1,LRNXL)'=LRNX Q:$G(LREND) D
. Q:$G(LREND)
. W !,@LRNODE
. I $Y+4>IOSL D HDR Q:$G(LREND)
W:$D(ZTQUEUED) !,$$CJ^XLFSTR("End of Report",IOM),!
END ;
I '$D(ZTSK) W:'$G(LREND) !,$$CJ^XLFSTR("End of Report",IOM),!
I $E(IOST,1,2)="P-" W @IOF
D ^%ZISC
D END^LRCAPPH3
Q:$G(LRDBUG)
K DIR,DIRUT,DUOUT,LRLINE,LRNODE,LRNXL,LRPAGE,LRREC,LRX
K LRPDT,LRPTNM,LRT,POP,ZTIO,ZTDESC,ZTRTN,ZTSAVE
S LREND=0
Q
HDR ;
Q:$G(LREND)
I LRPAGE,$E(IOST,1,2)="C-" D Q:$G(LREND)
. N DIR
. S DIR(0)="E" D ^DIR
. S LREND=$G(DIRUT)
. Q:$G(LREND) W @IOF,!!
S LRPAGE=$G(LRPAGE)+1 I $G(LRPAGE)>1 W @IOF
CNTR W $$CJ^XLFSTR(LRPTNM,IOM),!
W $$CJ^XLFSTR(LRPDT_" Page: "_LRPAGE,IOM)
W !,LRLINE,!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPPH4 2409 printed Sep 23, 2025@19:48:52 Page 2
LRCAPPH4 ;DALOI/RSH/FHS-PRINT CPT CODES ;1-OCT-1998
+1 ;;5.2;LAB SERVICE;**263**;Sep 27,1994
EN ;
+1 NEW LREND
+2 SET LREND=1
+3 WRITE @IOF,!!,$$CJ^XLFSTR("This option will print CPT CODE that have inactive",IOM)
+4 WRITE !,$$CJ^XLFSTR("date in the WKLD CODE(#64) ONLY",IOM)
+5 WRITE !!,$$CJ^XLFSTR("It DOES NOT provide a inactive CPT code list from",IOM)
+6 WRITE !,$$CJ^XLFSTR("the CPT (#81) file. ",IOM)
ASK ;
+1 KILL DIR
SET DIR(0)="SO^1:Ready to print INACTIVE CPT CODES REPORT;2:Abort"
+2 DO ^DIR
KILL DIR
+3 IF $SELECT($GET(DIRUT):1,$GET(DUOUT):1,$GET(DTOUT):1,Y=2:1,1:0)
GOTO END
+4 KILL %ZIS
SET %ZIS="Q"
DO ^%ZIS
+5 if POP
GOTO END
+6 IF $GET(IO("Q"))
Begin DoDot:1
+7 SET ZTRTN="ACTIVE^LRCAPPH4"
SET (LRION,ZTIO)=ION
SET ZTDESC="Print INVALID CPT CODE"
DO ^%ZTLOAD
+8 DO ^%ZISC
+9 if $DATA(ZTSK)'[0
WRITE !!?5," Tasked to Print on : ",LRION
HANG 5
+10 KILL LRION
End DoDot:1
GOTO END
+11 DO ACTIVE
+12 QUIT
ACTIVE ;Search ^LAM( and find INVALID CPT CODES
+1 SET LRACT=1
SET LREND=0
+2 DO EN^LRCAPPH3
+3 WRITE !
+4 if $GET(LREND)
QUIT
+5 DO DQ("^TMP(""LRCAPPH"","_$JOB)
+6 QUIT
DQ(LRNX) ;
+1 ; LRNODE= subscripted data storage array root
+2 ; ie ^TMP("LRCAPPH",$J OR X("LR"
+3 ; ^TMP("LRCAPPH",$J,0)="KERNEL DELETE DATE^REPORT DATE^REPORT NAME"
+4 NEW LREND
+5 if $DATA(ZTQUEUED)
SET ZTREQ="@"
SET LRPDT=$$FMTE^XLFDT($$NOW^XLFDT,"1P")
+6 SET (LRPAGE,LREND)=0
SET $PIECE(LRLINE,"=",(IOM-1))=""
+7 SET LRNXL=$LENGTH(LRNX)
SET LRNODE=LRNX
+8 IF $EXTRACT(LRNODE,$LENGTH(LRNX))'="("
IF $EXTRACT(LRNODE,$LENGTH(LRNX))'=","
SET LRNODE=LRNX_","
+9 IF $EXTRACT(LRNODE,$LENGTH(LRNODE))'=")"
SET LRNODE=LRNODE_"0)"
+10 if $SELECT('$LENGTH($PIECE(LRNODE,"("))
QUIT
+11 SET LRPTNM="Data listing of "_LRNODE
IO USE IO
+1 IF $DATA(@LRNODE)#2
Begin DoDot:1
+2 SET LRREC=$GET(@LRNODE)
+3 if $LENGTH($PIECE(LRREC,U,3))
SET LRPTNM=$PIECE(LRREC,U,3)
+4 SET LRPDT=$PIECE(LRREC,U,2)
+5 if LRPDT
SET LRPDT=$$FMTE^XLFDT(LRPDT,"1P")
+6 WRITE !
+7 DO HDR
End DoDot:1
+8 FOR
SET LRNODE=$QUERY(@LRNODE)
if $EXTRACT(LRNODE,1,LRNXL)'=LRNX
QUIT
if $GET(LREND)
QUIT
Begin DoDot:1
+9 if $GET(LREND)
QUIT
+10 WRITE !,@LRNODE
+11 IF $Y+4>IOSL
DO HDR
if $GET(LREND)
QUIT
End DoDot:1
+12 if $DATA(ZTQUEUED)
WRITE !,$$CJ^XLFSTR("End of Report",IOM),!
END ;
+1 IF '$DATA(ZTSK)
if '$GET(LREND)
WRITE !,$$CJ^XLFSTR("End of Report",IOM),!
+2 IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
+3 DO ^%ZISC
+4 DO END^LRCAPPH3
+5 if $GET(LRDBUG)
QUIT
+6 KILL DIR,DIRUT,DUOUT,LRLINE,LRNODE,LRNXL,LRPAGE,LRREC,LRX
+7 KILL LRPDT,LRPTNM,LRT,POP,ZTIO,ZTDESC,ZTRTN,ZTSAVE
+8 SET LREND=0
+9 QUIT
HDR ;
+1 if $GET(LREND)
QUIT
+2 IF LRPAGE
IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+3 NEW DIR
+4 SET DIR(0)="E"
DO ^DIR
+5 SET LREND=$GET(DIRUT)
+6 if $GET(LREND)
QUIT
WRITE @IOF,!!
End DoDot:1
if $GET(LREND)
QUIT
+7 SET LRPAGE=$GET(LRPAGE)+1
IF $GET(LRPAGE)>1
WRITE @IOF
CNTR WRITE $$CJ^XLFSTR(LRPTNM,IOM),!
+1 WRITE $$CJ^XLFSTR(LRPDT_" Page: "_LRPAGE,IOM)
+2 WRITE !,LRLINE,!!
+3 QUIT
