APCDRVH1.m

APCDRVH1 ; IHS/CMI/LAB - REVIEW HOSPITALIZATIONS CONT. ;

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

 ;

START ;

CHKDXOP ; CHECK DX VS OPERATIONS AND CHECK FOR DUPLICATE POVS

 K APCDDUPE,APCDPOVS,APCDDXP S APCDDX=0 F  S APCDDX=$O(^AUPNVPOV("AD",APCDVSIT,APCDDX)) Q:APCDDX=""  S APCDPOVS(APCDDX)="" D CHKDXOP1

 K APCDDUPO,APCDVPRC,APCDOPP S APCDPX=0 F  S APCDPX=$O(^AUPNVPRC("AD",APCDVSIT,APCDPX)) Q:APCDPX=""  S APCDOPDX=$P(^AUPNVPRC(APCDPX,0),U,5) S:APCDOPDX]"" APCDVPRC(APCDPX)=APCDOPDX_"^"_$$CODEC^ICDEX(80,APCDOPDX) D CHKDXOP2

 ;D C567

 S (C,O)=0 F  S O=$O(^AUPNVPOV("AD",APCDVSIT,O)) Q:C>0!(O'=+O)  I $P(^AUPNVPOV(O,0),U,12)="P" S C=C+1 D GETPOV

 S O=0 F  S O=$O(^AUPNVPOV("AD",APCDVSIT,O)) Q:O'=+O  I $P(^AUPNVPOV(O,0),U,12)'="P" S C=C+1 D GETPOV ;IHS/CMI/LAB - FIX # of diagnoses per Cheryl Chase

 S (C,O)=0 F  S O=$O(^AUPNVPRC("AD",APCDVSIT,O)) Q:C>2!(O'=+O)  S C=C+1 D GETPRC

 ;

XIT ;

 K APCD1,APCD2,APCDDX,APCDPX,APCDOPDX,APCDDUPE,APCDDUPO,APCDDXP,APCDOPP,APCDFOUN,APCDOPC,APCDDXC,APCDPR,APCDPRC,APCDVPRC,APCDPOVS,APCDOP,APCDRVH1,C,O,N

 Q

GETPOV ;

 S APCDRVH1("ICD PTR")=$P(^AUPNVPOV(O,0),U),APCDRVH1("ICD")=$$CODEC^ICDEX(80,APCDRVH1("ICD PTR"))

 S APCDRVH1("POV",C)=APCDRVH1("ICD")

 Q

GETPRC ;

 S APCDRVH1("O PTR")=$P(^AUPNVPRC(O,0),U)

 S (APCDRVH1("OH"),N)="",APCDRVH1("OH")=$$CODEC^ICDEX(80.1,APCDRVH1("O PTR"))

 S APCDRVH1("ICD")="",APCDRVH1("ICD PTR")=$P(^AUPNVPRC(O,0),U,5) I APCDRVH1("ICD PTR")="" S APCDE="E336" D ERR Q

 S APCDRVH1("ICD")=$$CODEC^ICDEX(80,APCDRVH1("ICD PTR"))

 S X=0,APCDRVH1("DX")="" F  S X=$O(APCDRVH1("POV",X)) Q:X'=+X  I APCDRVH1("POV",X)=APCDRVH1("ICD") S APCDRVH1("DX")=X

 ;I APCDRVH1("DX")="" S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E334" D ERR

 Q

ERR ;

 D ERR^APCDRV

 Q

CHKDXOP1 ;

 I $D(APCDDXP($P(^AUPNVPOV(APCDDX,0),U))) S APCDDUPE=1

 S APCDDXP($P(^AUPNVPOV(APCDDX,0),U))=""

 Q

CHKDXOP2 ;

 I APCDOPDX="" S APCDE="E044",APCDE("FILE")=9000010.08,APCDE("ENTRY")=APCDPX D ERR

 I $D(APCDOPP($P(^AUPNVPRC(APCDPX,0),U))) S APCDDUPO=1

 S APCDOPP($P(^AUPNVPRC(APCDPX,0),U))=""

 K APCDFOUN F  S APCDDX=$O(APCDDXP(APCDDX)) Q:APCDDX=""  I APCDDX=APCDOPDX S APCDFOUN=1

 Q

DUPE ;

 S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E315" D ERR

 Q

DUPEOP ;WARNING RE:  DUPLICATE OPERATIONS USED;ACCEPT REQUIRED

 S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E316" D ERR

 Q

 ;

C567 ;CHK DX VS OPS

 ;S APCD1=0 F  S APCD1=$O(APCDPOVS(APCD1)) Q:APCD1=""  S APCDDX=$P(^AUPNVPOV(APCD1,0),U) I $D(^APCDINPT(6,11,"AC",$$CODEC^ICDEX(80,APCDDX))) D C6ERR

 ;;Q

C6ERR ;

 I '$D(APCDVPRC) S APCDE="E333",APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT D ERR Q

 ;K APCDFOUN S APCD2=0 F  S APCD2=$O(APCDVPRC(APCD2)) Q:APCD2=""  S APCDOP=$$CODEC^ICDEX(80.1,$P(^AUPNVPRC(APCD2,0),U)) I $D(^APCDINPT(6,12,"AC",APCDOP)),$P(APCDVPRC(APCD2),U,1)=APCDDX S APCDFOUN=1

 ;I '$D(APCDFOUN)  S APCDE="E333",APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT D ERR

 ;Q

APCDRVH1  ; IHS/CMI/LAB - REVIEW HOSPITALIZATIONS CONT. ;

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

 +2       ;

START     ;

CHKDXOP   ; CHECK DX VS OPERATIONS AND CHECK FOR DUPLICATE POVS

 +1        KILL APCDDUPE,APCDPOVS,APCDDXP

           SET APCDDX=0

           FOR 

               SET APCDDX=$ORDER(^AUPNVPOV("AD",APCDVSIT,APCDDX))

               IF APCDDX=""

                   QUIT 

               SET APCDPOVS(APCDDX)=""

               DO CHKDXOP1

 +2        KILL APCDDUPO,APCDVPRC,APCDOPP

           SET APCDPX=0

           FOR 

               SET APCDPX=$ORDER(^AUPNVPRC("AD",APCDVSIT,APCDPX))

               IF APCDPX=""

                   QUIT 

               SET APCDOPDX=$PIECE(^AUPNVPRC(APCDPX,0),U,5)

               IF APCDOPDX]""

                   SET APCDVPRC(APCDPX)=APCDOPDX_"^"_$$CODEC^ICDEX(80,APCDOPDX)

               DO CHKDXOP2

 +3       ;D C567

 +4        SET (C,O)=0

           FOR 

               SET O=$ORDER(^AUPNVPOV("AD",APCDVSIT,O))

               IF C>0!(O'=+O)

                   QUIT 

               IF $PIECE(^AUPNVPOV(O,0),U,12)="P"

                   SET C=C+1

                   DO GETPOV

 +5       ;IHS/CMI/LAB - FIX # of diagnoses per Cheryl Chase

           SET O=0

           FOR 

               SET O=$ORDER(^AUPNVPOV("AD",APCDVSIT,O))

               IF O'=+O

                   QUIT 

               IF $PIECE(^AUPNVPOV(O,0),U,12)'="P"

                   SET C=C+1

                   DO GETPOV

 +6        SET (C,O)=0

           FOR 

               SET O=$ORDER(^AUPNVPRC("AD",APCDVSIT,O))

               IF C>2!(O'=+O)

                   QUIT 

               SET C=C+1

               DO GETPRC

 +7       ;

XIT       ;

 +1        KILL APCD1,APCD2,APCDDX,APCDPX,APCDOPDX,APCDDUPE,APCDDUPO,APCDDXP,APCDOPP,APCDFOUN,APCDOPC,APCDDXC,APCDPR,APCDPRC,APCDVPRC,APCDPOVS,APCDOP,APCDRVH1,C,O,N

 +2        QUIT 

GETPOV    ;

 +1        SET APCDRVH1("ICD PTR")=$PIECE(^AUPNVPOV(O,0),U)

           SET APCDRVH1("ICD")=$$CODEC^ICDEX(80,APCDRVH1("ICD PTR"))

 +2        SET APCDRVH1("POV",C)=APCDRVH1("ICD")

 +3        QUIT 

GETPRC    ;

 +1        SET APCDRVH1("O PTR")=$PIECE(^AUPNVPRC(O,0),U)

 +2        SET (APCDRVH1("OH"),N)=""

           SET APCDRVH1("OH")=$$CODEC^ICDEX(80.1,APCDRVH1("O PTR"))

 +3        SET APCDRVH1("ICD")=""

           SET APCDRVH1("ICD PTR")=$PIECE(^AUPNVPRC(O,0),U,5)

           IF APCDRVH1("ICD PTR")=""

               SET APCDE="E336"

               DO ERR

               QUIT 

 +4        SET APCDRVH1("ICD")=$$CODEC^ICDEX(80,APCDRVH1("ICD PTR"))

 +5        SET X=0

           SET APCDRVH1("DX")=""

           FOR 

               SET X=$ORDER(APCDRVH1("POV",X))

               IF X'=+X

                   QUIT 

               IF APCDRVH1("POV",X)=APCDRVH1("ICD")

                   SET APCDRVH1("DX")=X

 +6       ;I APCDRVH1("DX")="" S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E334" D ERR

 +7        QUIT 

ERR       ;

 +1        DO ERR^APCDRV

 +2        QUIT 

CHKDXOP1  ;

 +1        IF $DATA(APCDDXP($PIECE(^AUPNVPOV(APCDDX,0),U)))

               SET APCDDUPE=1

 +2        SET APCDDXP($PIECE(^AUPNVPOV(APCDDX,0),U))=""

 +3        QUIT 

CHKDXOP2  ;

 +1        IF APCDOPDX=""

               SET APCDE="E044"

               SET APCDE("FILE")=9000010.08

               SET APCDE("ENTRY")=APCDPX

               DO ERR

 +2        IF $DATA(APCDOPP($PIECE(^AUPNVPRC(APCDPX,0),U)))

               SET APCDDUPO=1

 +3        SET APCDOPP($PIECE(^AUPNVPRC(APCDPX,0),U))=""

 +4        KILL APCDFOUN

           FOR 

               SET APCDDX=$ORDER(APCDDXP(APCDDX))

               IF APCDDX=""

                   QUIT 

               IF APCDDX=APCDOPDX

                   SET APCDFOUN=1

 +5        QUIT 

DUPE      ;

 +1        SET APCDE("FILE")=9000010

           SET APCDE("ENTRY")=APCDVSIT

           SET APCDE="E315"

           DO ERR

 +2        QUIT 

DUPEOP    ;WARNING RE:  DUPLICATE OPERATIONS USED;ACCEPT REQUIRED

 +1        SET APCDE("FILE")=9000010

           SET APCDE("ENTRY")=APCDVSIT

           SET APCDE="E316"

           DO ERR

 +2        QUIT 

 +3       ;

C567      ;CHK DX VS OPS

 +1       ;S APCD1=0 F  S APCD1=$O(APCDPOVS(APCD1)) Q:APCD1=""  S APCDDX=$P(^AUPNVPOV(APCD1,0),U) I $D(^APCDINPT(6,11,"AC",$$CODEC^ICDEX(80,APCDDX))) D C6ERR

 +2       ;;Q

C6ERR     ;

 +1        IF '$DATA(APCDVPRC)

               SET APCDE="E333"

               SET APCDE("FILE")=9000010

               SET APCDE("ENTRY")=APCDVSIT

               DO ERR

               QUIT 

 +2       ;K APCDFOUN S APCD2=0 F  S APCD2=$O(APCDVPRC(APCD2)) Q:APCD2=""  S APCDOP=$$CODEC^ICDEX(80.1,$P(^AUPNVPRC(APCD2,0),U)) I $D(^APCDINPT(6,12,"AC",APCDOP)),$P(APCDVPRC(APCD2),U,1)=APCDDX S APCDFOUN=1

 +3       ;I '$D(APCDFOUN)  S APCDE="E333",APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT D ERR

 +4       ;Q