- LRCAPPH4 ;DALOI/RSH/FHS-PRINT CPT CODES ;1-OCT-1998
- ;;5.2T9;LR;**1018**;Nov 17, 2004
- ;;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
- LRCAPPH4 ;DALOI/RSH/FHS-PRINT CPT CODES ;1-OCT-1998
- +1 ;;5.2T9;LR;**1018**;Nov 17, 2004
- +2 ;;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
