APCLOS61.m

APCLOS61 ; IHS/CMI/LAB - ambulatory continued ;

 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

 ;

 ;cmi/anch/maw 9/10/2007 code set versioning in APC

 ;

 D PROV

 D POV

 Q

COUNT ;

 I '$D(@X) S @X=0

 S %=@X,%=%+1,@X=%

 Q

PROV ;provider type

 S APCLX=0 F  S APCLX=$O(^AUPNVPRV("AD",APCLVDFN,APCLX)) Q:APCLX'=+APCLX  I $D(^AUPNVPRV(APCLX,0)) D PROV1

 Q

PROV1 ;

 S APCLPROV=$P(^AUPNVPRV(APCLX,0),U)

CHKDISC ;

 I $P(^DD(9000010.06,.01,0),U,2)[200 S APCLDISC=$$PROVCLS^XBFUNC1(APCLPROV) G CHKDISC1

 S APCLY=$P(^DIC(6,APCLPROV,0),U,4)

 I APCLY="" S APCLDISC="DISCIPLINE UNAVAILABLE" G CHKDISC1

 S APCLDISC=$P(^DIC(7,APCLY,0),U) Q:APCLDISC=""

CHKDISC1 S X=APCLP D COUNT

 Q

 ;

POV ;

 S APCLPDFN=0 F  S APCLPDFN=$O(^AUPNVPOV("AD",APCLVDFN,APCLPDFN)) Q:APCLPDFN'=+APCLPDFN  I $D(^AUPNVPOV(APCLPDFN,0)) D POV1

 Q

POV1 ;

 S APCLPOV=$P(^AUPNVPOV(APCLPDFN,0),U)

 Q:'$D(^ICD9(APCLPOV,0))

 ;

 S X=APCLA D COUNT

APC ;

 Q  ;1/6/200 - no longer do this.

 ;S APCLX=$P(^ICD9(APCLPOV,0),U),APCLAPC=APCLAPCD D ^APCLRAPC  ;cmi/anch/maw 9/10/2007 orig line

 S APCLX=$P($$ICDDX^ICDEX(APCLPOV),U,2),APCLAPC=APCLAPCD D ^APCLRAPC  ;cmi/anch/maw 9/10/2007 csv

 S X=APCLH D COUNT

 Q

 ;

APCLOS61  ; IHS/CMI/LAB - ambulatory continued ;

 +1       ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

 +2       ;

 +3       ;cmi/anch/maw 9/10/2007 code set versioning in APC

 +4       ;

 +5        DO PROV

 +6        DO POV

 +7        QUIT 

COUNT     ;

 +1        IF '$DATA(@X)

               SET @X=0

 +2        SET %=@X

           SET %=%+1

           SET @X=%

 +3        QUIT 

PROV      ;provider type

 +1        SET APCLX=0

           FOR 

               SET APCLX=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCLX))

               IF APCLX'=+APCLX

                   QUIT 

               IF $DATA(^AUPNVPRV(APCLX,0))

                   DO PROV1

 +2        QUIT 

PROV1     ;

 +1        SET APCLPROV=$PIECE(^AUPNVPRV(APCLX,0),U)

CHKDISC   ;

 +1        IF $PIECE(^DD(9000010.06,.01,0),U,2)[200

               SET APCLDISC=$$PROVCLS^XBFUNC1(APCLPROV)

               GOTO CHKDISC1

 +2        SET APCLY=$PIECE(^DIC(6,APCLPROV,0),U,4)

 +3        IF APCLY=""

               SET APCLDISC="DISCIPLINE UNAVAILABLE"

               GOTO CHKDISC1

 +4        SET APCLDISC=$PIECE(^DIC(7,APCLY,0),U)

           IF APCLDISC=""

               QUIT 

CHKDISC1   SET X=APCLP

           DO COUNT

 +1        QUIT 

 +2       ;

POV       ;

 +1        SET APCLPDFN=0

           FOR 

               SET APCLPDFN=$ORDER(^AUPNVPOV("AD",APCLVDFN,APCLPDFN))

               IF APCLPDFN'=+APCLPDFN

                   QUIT 

               IF $DATA(^AUPNVPOV(APCLPDFN,0))

                   DO POV1

 +2        QUIT 

POV1      ;

 +1        SET APCLPOV=$PIECE(^AUPNVPOV(APCLPDFN,0),U)

 +2        IF '$DATA(^ICD9(APCLPOV,0))

               QUIT 

 +3       ;

 +4        SET X=APCLA

           DO COUNT

APC       ;

 +1       ;1/6/200 - no longer do this.

           QUIT 

 +2       ;S APCLX=$P(^ICD9(APCLPOV,0),U),APCLAPC=APCLAPCD D ^APCLRAPC  ;cmi/anch/maw 9/10/2007 orig line

 +3       ;cmi/anch/maw 9/10/2007 csv

           SET APCLX=$PIECE($$ICDDX^ICDEX(APCLPOV),U,2)

           SET APCLAPC=APCLAPCD

           DO ^APCLRAPC

 +4        SET X=APCLH

           DO COUNT

 +5        QUIT 

 +6       ;