AICDPRTO.m

AICDPRTO ; IHS/OHPRD/ACC - PROGRAM TO PRINT ICD PROCEDURE FILE IN CODE ORDER ;

 ;;3.51;IHS ICD/CPT lookup & grouper;;MAY 30, 1991

 ; NEEDED TO PRINT IN CODE ORDER DUE TO LOSS OF B INDEX

 ;

 K ZTSK

 K IO,IOP,%ZIS S %ZIS="PQ" D ^%ZIS I POP S IO=IO(0) Q

 G:$D(IO("Q")) QUE

NOQUE D EN

 Q

QUE K ZTSAVE

 S ZTRTN="EN^AICDPRTO",ZTDESC="PRINT ICD PROCEDURE FILE BY CODE",ZTIO=ION,ZTDTH=DT

 D ^%ZTLOAD

 D HOME^%ZIS

 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK

 Q

 ;

EN ; ENTRY POINT - FROM TASKMAN FOR QUEUED PRINTING

 U IO

 W:$P(IOST,"-",1)="C" @IOF,!

 W "--- ICD9 (PROCEDURE) CODE LISTING ---",!!

 S AICDCODE=" " F AICDI=0:0 S AICDCODE=$O(^ICD0("BA",AICDCODE)) Q:AICDCODE=""  S AICDDFN=$O(^(AICDCODE,0)) D PCODE

 W:$P(IOST,"-",1)="P" @IOF

 D ^%ZISC

 K AICDDFN

 Q

PCODE ;

 W AICDCODE,?10,$E("*",$P(^ICD0(AICDDFN,0),U,9))

 S X=$S($D(^(1)):^(1),1:$P(^(0),U,4)_" <brief form>")

 F  W ?12,$E(X,1,IOM-12),! S X=$E(X,IOM-11,$L(X)) Q:X=""

 I $P(IOST,"-",1)="P",$Y>(IOSL-1) W @IOF

 Q

AICDPRTO  ; IHS/OHPRD/ACC - PROGRAM TO PRINT ICD PROCEDURE FILE IN CODE ORDER ;

 +1       ;;3.51;IHS ICD/CPT lookup & grouper;;MAY 30, 1991

 +2       ; NEEDED TO PRINT IN CODE ORDER DUE TO LOSS OF B INDEX

 +3       ;

 +4        KILL ZTSK

 +5        KILL IO,IOP,%ZIS

           SET %ZIS="PQ"

           DO ^%ZIS

           IF POP

               SET IO=IO(0)

               QUIT 

 +6        IF $DATA(IO("Q"))

               GOTO QUE

NOQUE      DO EN

 +1        QUIT 

QUE        KILL ZTSAVE

 +1        SET ZTRTN="EN^AICDPRTO"

           SET ZTDESC="PRINT ICD PROCEDURE FILE BY CODE"

           SET ZTIO=ION

           SET ZTDTH=DT

 +2        DO ^%ZTLOAD

 +3        DO HOME^%ZIS

 +4        KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK

 +5        QUIT 

 +6       ;

EN        ; ENTRY POINT - FROM TASKMAN FOR QUEUED PRINTING

 +1        USE IO

 +2        IF $PIECE(IOST,"-",1)="C"

               WRITE @IOF,!

 +3        WRITE "--- ICD9 (PROCEDURE) CODE LISTING ---",!!

 +4        SET AICDCODE=" "

           FOR AICDI=0:0

               SET AICDCODE=$ORDER(^ICD0("BA",AICDCODE))

               IF AICDCODE=""

                   QUIT 

               SET AICDDFN=$ORDER(^(AICDCODE,0))

               DO PCODE

 +5        IF $PIECE(IOST,"-",1)="P"

               WRITE @IOF

 +6        DO ^%ZISC

 +7        KILL AICDDFN

 +8        QUIT 

PCODE     ;

 +1        WRITE AICDCODE,?10,$EXTRACT("*",$PIECE(^ICD0(AICDDFN,0),U,9))

 +2        SET X=$SELECT($DATA(^(1)):^(1),1:$PIECE(^(0),U,4)_" <brief form>")

 +3        FOR 

               WRITE ?12,$EXTRACT(X,1,IOM-12),!

               SET X=$EXTRACT(X,IOM-11,$LENGTH(X))

               IF X=""

                   QUIT 

 +4        IF $PIECE(IOST,"-",1)="P"

               IF $Y>(IOSL-1)

                   WRITE @IOF

 +5        QUIT