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