APCLOS41.m

APCLOS41 ; 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)

 ;Q:'$D(^DIC(6,APCLPROV))

 ;Q:'$D(^DIC(16,APCLPROV))

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)

 I APCLEXCL=1,$D(APCLDXT(APCLPOV)) Q

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

 ;

 S X=APCLA D COUNT

APC ;

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

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

 S APCLCS=$P(APCLX,U,20) ;CODING SYSTEM

 S APCLCO=$P(APCLX,U,2) ;CODE

 S APCLX=$P(APCLX,U,1) ;IEN

 ;S X=APCLH D COUNT

ALCH ;

 G:APCLCLNC'=30 INJURY

 G:$D(APCLALCH) INJURY

 S:$$ICD^ATXAPI(APCLX,$O(^ATXAX("B","BGP ALCOHOL DXS",0)),9) ^("ERALCHCOUNT")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"ERALCHCOUNT")):^("ERALCHCOUNT")+1,1:1),APCLALCH=""

INJURY ;

 Q:$D(APCLINJF)

 Q:APCLX=""

 Q:'$$INJ^APCDAPOV(APCLCO,APCLCS)

 S ^("INJCOUNT")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"INJCOUNT")):^("INJCOUNT")+1,1:1)

 I APCLCLNC=30 S ^("ERINJCOUNT")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"ERINJCOUNT")):^("ERINJCOUNT")+1,1:1)

 I $P(^AUPNVPOV(APCLPDFN,0),U,8)=1 S ^("INJFIRST")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"INJFIRST")):^("INJFIRST")+1,1:1)

 S APCLINJF=""

CAUSE S APCLINJ=$P(^AUPNVPOV(APCLPDFN,0),U,9) Q:APCLINJ=""

 S X=APCLD D COUNT

 Q

 ;

APCLOS41  ; 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)

 +2       ;Q:'$D(^DIC(6,APCLPROV))

 +3       ;Q:'$D(^DIC(16,APCLPROV))

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 APCLEXCL=1

               IF $DATA(APCLDXT(APCLPOV))

                   QUIT 

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

               QUIT 

 +4       ;

 +5        SET X=APCLA

           DO COUNT

APC       ;

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

 +2       ;D ^APCLRAPC cmi/anch/maw 9/10/2007 csv

           SET APCLX=$$ICDDX^ICDEX(APCLPOV)

           SET APCLAPC=APCLAPCD

 +3       ;CODING SYSTEM

           SET APCLCS=$PIECE(APCLX,U,20)

 +4       ;CODE

           SET APCLCO=$PIECE(APCLX,U,2)

 +5       ;IEN

           SET APCLX=$PIECE(APCLX,U,1)

 +6       ;S X=APCLH D COUNT

ALCH      ;

 +1        IF APCLCLNC'=30

               GOTO INJURY

 +2        IF $DATA(APCLALCH)

               GOTO INJURY

 +3        IF $$ICD^ATXAPI(APCLX,$ORDER(^ATXAX("B","BGP ALCOHOL DXS",0)),9)

               SET ^("ERALCHCOUNT")=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"ERALCHCOUNT")):^("ERALCHCOUNT")+1,1:1)

               SET APCLALCH=""

INJURY    ;

 +1        IF $DATA(APCLINJF)

               QUIT 

 +2        IF APCLX=""

               QUIT 

 +3        IF '$$INJ^APCDAPOV(APCLCO,APCLCS)

               QUIT 

 +4        SET ^("INJCOUNT")=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"INJCOUNT")):^("INJCOUNT")+1,1:1)

 +5        IF APCLCLNC=30

               SET ^("ERINJCOUNT")=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"ERINJCOUNT")):^("ERINJCOUNT")+1,1:1)

 +6        IF $PIECE(^AUPNVPOV(APCLPDFN,0),U,8)=1

               SET ^("INJFIRST")=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"INJFIRST")):^("INJFIRST")+1,1:1)

 +7        SET APCLINJF=""

CAUSE      SET APCLINJ=$PIECE(^AUPNVPOV(APCLPDFN,0),U,9)

           IF APCLINJ=""

               QUIT 

 +1        SET X=APCLD

           DO COUNT

 +2        QUIT 

 +3       ;