ICPTPRN.m

ICPTPRN ;ALB/MTC,RMO,ABR,MRY - CPT PRINT-OUT DRIVER ; 1/03/03 3:21pm

 ;;6.0;CPT/HCPCS;**4,8,9,12,13**;May 19, 1997;Build 44

 ;

 ;modified to sort in code name order using temp global;abr 1/96

 ;

 ;

AM3 ;-- Recently Inactivated CPT Codes

 N DGDATE,FR,TO,BY

 D INIT

 S DHD="Recently INACTIVATED CPT Codes effective Jan 01, 2003"

 ; rev w/new Inactive Date - changed 2990401 to 3000401 (ERC)

 ;                                              3010401 (JKT)

 ;                                              3020401 (JT)

 ;                                              3030101 (MRY)

 S BY="[ICPT NEW/INACTIVE CODES]",(FR,TO)="3030101,1,"

 D EN1^DIP

 G PRTQ

 ;

AM4 ;-- New CPT Codes

 N DGDATE,FR,TO,BY

 D INIT

 S DHD="NEW CPT Codes effective "_$P(DGDATE,U,2)

 S BY="[ICPT NEW/INACTIVE CODES]",FR=+DGDATE_",@,",TO=+DGDATE_",@,"

 D EN1^DIP

 G PRTQ

 ;

AM5 ;-- Revised CPT Codes

 N DGDATE,DGSRT,FR,TO,BY

 K ^TMP("REVCPT",$J)

 S DGSRT="REVCPT"

 D ^ICPTSR1 ; sorts by revised codes

 D INIT

 S BY(0)="^TMP(""REVCPT"",$J,",L(0)=2,DHD="Recently REVISED CPT Codes effective "_$P(DGDATE,U,2)

 D EN1^DIP

 K ^TMP("REVCPT",$J)

 G PRTQ

 ;

INIT ;--init common items for print routines

 N X,Y

 S (X,DGDATE)=$$CPTDIST^ICPTAPIU,Y="D"

 S $P(DGDATE,U,2)=$$FMTE^XLFDT(X)

 W !,$C(7),"This report requires 132 columns."

 S L=0,DIC="^ICPT(",FLDS="[ICPT PRINT]"

 Q

PRTQ ;--clean-up and exit

 K DHD,FLDS,L,DIC,BY,DIS,ICPTX,ICPTY,ICPTK

 Q

 ;

CPTMOD ; --Modifiers for a range

 ;

 NEW DIC,L,FLDS,BY

 S DIC="^DIC(81.3,",L=0,FLDS="[ICPT MODIFIERS BY RANGE]",BY="[ICPT MODIFIERS FOR RANGE]"

 W !,$C(7),"This report requires 132 columns."

 D EN1^DIP

 Q

ICPTPRN   ;ALB/MTC,RMO,ABR,MRY - CPT PRINT-OUT DRIVER ; 1/03/03 3:21pm

 +1       ;;6.0;CPT/HCPCS;**4,8,9,12,13**;May 19, 1997;Build 44

 +2       ;

 +3       ;modified to sort in code name order using temp global;abr 1/96

 +4       ;

 +5       ;

AM3       ;-- Recently Inactivated CPT Codes

 +1        NEW DGDATE,FR,TO,BY

 +2        DO INIT

 +3        SET DHD="Recently INACTIVATED CPT Codes effective Jan 01, 2003"

 +4       ; rev w/new Inactive Date - changed 2990401 to 3000401 (ERC)

 +5       ;                                              3010401 (JKT)

 +6       ;                                              3020401 (JT)

 +7       ;                                              3030101 (MRY)

 +8        SET BY="[ICPT NEW/INACTIVE CODES]"

           SET (FR,TO)="3030101,1,"

 +9        DO EN1^DIP

 +10       GOTO PRTQ

 +11      ;

AM4       ;-- New CPT Codes

 +1        NEW DGDATE,FR,TO,BY

 +2        DO INIT

 +3        SET DHD="NEW CPT Codes effective "_$PIECE(DGDATE,U,2)

 +4        SET BY="[ICPT NEW/INACTIVE CODES]"

           SET FR=+DGDATE_",@,"

           SET TO=+DGDATE_",@,"

 +5        DO EN1^DIP

 +6        GOTO PRTQ

 +7       ;

AM5       ;-- Revised CPT Codes

 +1        NEW DGDATE,DGSRT,FR,TO,BY

 +2        KILL ^TMP("REVCPT",$JOB)

 +3        SET DGSRT="REVCPT"

 +4       ; sorts by revised codes

           DO ^ICPTSR1

 +5        DO INIT

 +6        SET BY(0)="^TMP(""REVCPT"",$J,"

           SET L(0)=2

           SET DHD="Recently REVISED CPT Codes effective "_$PIECE(DGDATE,U,2)

 +7        DO EN1^DIP

 +8        KILL ^TMP("REVCPT",$JOB)

 +9        GOTO PRTQ

 +10      ;

INIT      ;--init common items for print routines

 +1        NEW X,Y

 +2        SET (X,DGDATE)=$$CPTDIST^ICPTAPIU

           SET Y="D"

 +3        SET $PIECE(DGDATE,U,2)=$$FMTE^XLFDT(X)

 +4        WRITE !,$CHAR(7),"This report requires 132 columns."

 +5        SET L=0

           SET DIC="^ICPT("

           SET FLDS="[ICPT PRINT]"

 +6        QUIT 

PRTQ      ;--clean-up and exit

 +1        KILL DHD,FLDS,L,DIC,BY,DIS,ICPTX,ICPTY,ICPTK

 +2        QUIT 

 +3       ;

CPTMOD    ; --Modifiers for a range

 +1       ;

 +2        NEW DIC,L,FLDS,BY

 +3        SET DIC="^DIC(81.3,"

           SET L=0

           SET FLDS="[ICPT MODIFIERS BY RANGE]"

           SET BY="[ICPT MODIFIERS FOR RANGE]"

 +4        WRITE !,$CHAR(7),"This report requires 132 columns."

 +5        DO EN1^DIP

 +6        QUIT