APCLRAPC.m

APCLRAPC ; IHS/CMI/LAB - recode ICD Diagnosis Code into APC code ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 S APCLXHOL=APCLX

 I '$D(APCLX) S APCLERR=1,APCLMSG="APCLX VARIABLE NOT DEFINED" Q

 I APCLX="" S APCLERR=1,APCLMSG="APCLX VARIABLE IS NULL" Q

 I $E(APCLX)="." D CODE10 G HIGH

 S APCLICD="09"_($P(APCLX,".")_$P(APCLX,".",2))_" "

 I $E(APCLX)="V" S APCLX=9_$E(APCLX,2,9999),APCLX=APCLX-.000001,APCLX="09V"_$E(APCLX,2,9999),APCLX=$P(APCLX,".")_$P(APCLX,".",2)_" " G HIGH

 S APCLX="09"_APCLX-.000001

 S APCLY="",APCLX="0"_($P(APCLX,".")_$P(APCLX,".",2))_" "

HIGH S APCLHIGH=$O(^AUTTRCD("AH",APCLX)) I APCLHIGH="" S APCLY=999 G XIT

 S APCLDA1=$O(^AUTTRCD("AH",APCLHIGH,"")) I APCLDA1="" S APCLERR=1,APCLMSG="E99-ERROR IN APC RECODE XREF" Q

 S APCLDA2=$O(^AUTTRCD("AH",APCLHIGH,APCLDA1,""))

 S APCLLOW=$P(^AUTTRCD(APCLDA1,11,APCLDA2,0),U)_" "

 I APCLLOW]APCLICD S APCLY=999 G XIT

 S APCLY=$P(^AUTTRCD(APCLDA1,0),U),APCLAPC=APCLDA1

XIT ;

 K APCLICD,APCLLOW,APCLHIGH,APCLDA2,APCLDA1

 S APCLX=APCLXHOL K APCLXHOL

 Q

CODE10 ;

 S APCLICD="10"_$P(APCLX,".",2)_" "

 S APCLX="10"_APCLX,APCLX=APCLX-.000001,APCLX=$P(APCLX,".")_$P(APCLX,".",2)_" "

 Q

 ;

APCLRAPC  ; IHS/CMI/LAB - recode ICD Diagnosis Code into APC code ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2        SET APCLXHOL=APCLX

 +3        IF '$DATA(APCLX)

               SET APCLERR=1

               SET APCLMSG="APCLX VARIABLE NOT DEFINED"

               QUIT 

 +4        IF APCLX=""

               SET APCLERR=1

               SET APCLMSG="APCLX VARIABLE IS NULL"

               QUIT 

 +5        IF $EXTRACT(APCLX)="."

               DO CODE10

               GOTO HIGH

 +6        SET APCLICD="09"_($PIECE(APCLX,".")_$PIECE(APCLX,".",2))_" "

 +7        IF $EXTRACT(APCLX)="V"

               SET APCLX=9_$EXTRACT(APCLX,2,9999)

               SET APCLX=APCLX-.000001

               SET APCLX="09V"_$EXTRACT(APCLX,2,9999)

               SET APCLX=$PIECE(APCLX,".")_$PIECE(APCLX,".",2)_" "

               GOTO HIGH

 +8        SET APCLX="09"_APCLX-.000001

 +9        SET APCLY=""

           SET APCLX="0"_($PIECE(APCLX,".")_$PIECE(APCLX,".",2))_" "

HIGH       SET APCLHIGH=$ORDER(^AUTTRCD("AH",APCLX))

           IF APCLHIGH=""

               SET APCLY=999

               GOTO XIT

 +1        SET APCLDA1=$ORDER(^AUTTRCD("AH",APCLHIGH,""))

           IF APCLDA1=""

               SET APCLERR=1

               SET APCLMSG="E99-ERROR IN APC RECODE XREF"

               QUIT 

 +2        SET APCLDA2=$ORDER(^AUTTRCD("AH",APCLHIGH,APCLDA1,""))

 +3        SET APCLLOW=$PIECE(^AUTTRCD(APCLDA1,11,APCLDA2,0),U)_" "

 +4        IF APCLLOW]APCLICD

               SET APCLY=999

               GOTO XIT

 +5        SET APCLY=$PIECE(^AUTTRCD(APCLDA1,0),U)

           SET APCLAPC=APCLDA1

XIT       ;

 +1        KILL APCLICD,APCLLOW,APCLHIGH,APCLDA2,APCLDA1

 +2        SET APCLX=APCLXHOL

           KILL APCLXHOL

 +3        QUIT 

CODE10    ;

 +1        SET APCLICD="10"_$PIECE(APCLX,".",2)_" "

 +2        SET APCLX="10"_APCLX

           SET APCLX=APCLX-.000001

           SET APCLX=$PIECE(APCLX,".")_$PIECE(APCLX,".",2)_" "

 +3        QUIT 

 +4       ;