APCDR02.m

APCDR02 ; IHS/CMI/LAB - V HOSPITALIZATION REVIEW ;

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

 S APCDEREC=^AUPNVINP(APCDEDFN,0)

ADMTYPE ; Admission Type

 I $P(APCDEREC,U,7)="" S APCDE="E031" D ERR G DISP

 I $P(^DD(9000010.02,.07,0),U,2)[42.1 S X=$$VAL^XBDIQ1(42.1,$P(APCDEREC,U,7),9999999.01)

 I $P(^DD(9000010.02,.07,0),U,2)[405.1 S X=$$VAL^XBDIQ1(405.1,$P(APCDEREC,U,7),9999999.1)

 I X="" S APCDE="E031" D ERR

DISP ; Disposition Type-CP 60 

 S APCDDISP=""

 I $P(APCDEREC,U,6)="" S APCDE="E034" D ERR G UCAUS

 I $P(^DD(9000010.02,.06,0),U,2)[42.2 S APCDDISP=$$VAL^XBDIQ1(42.2,$P(APCDEREC,U,6),9999999.01)

 I $P(^DD(9000010.02,.06,0),U,2)[405.1 S APCDDISP=$$VAL^XBDIQ1(405.1,$P(APCDEREC,U,6),9999999.1)

 I $L(APCDDISP)'=1 S APCDE="E039" D ERR

 ;

 ;

UCAUS ; Underlying cause of death-CP 76-80.

 I APCDDISP<4 G XIT

 I '$D(^AUPNPAT(AUPNPAT,11)) S APCDE="E602" D ERR G XIT

 S APCDICDP=$P(^AUPNPAT(AUPNPAT,11),U,14) I APCDICDP="" S APCDE="E030" D ERR G XIT

 S APCDICD=$$CODEC^ICDEX(80,APCDICDP)

 K APCDE,APCDAGEE

 D ^APCDRICD

 I $D(APCDE) D ERR

 ;

 ;

XIT ; Clean up and exit

 K APCDDISP,APCDICDP,APCDICD,APCDAGEE,APCDEREC,APCDE

 Q

ERR ;

 S APCDE("FILE")=9000010.02,APCDE("ENTRY")=APCDEDFN

 D ERR^APCDRV

 Q

APCDR02   ; IHS/CMI/LAB - V HOSPITALIZATION REVIEW ;

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

 +2        SET APCDEREC=^AUPNVINP(APCDEDFN,0)

ADMTYPE   ; Admission Type

 +1        IF $PIECE(APCDEREC,U,7)=""

               SET APCDE="E031"

               DO ERR

               GOTO DISP

 +2        IF $PIECE(^DD(9000010.02,.07,0),U,2)[42.1

               SET X=$$VAL^XBDIQ1(42.1,$PIECE(APCDEREC,U,7),9999999.01)

 +3        IF $PIECE(^DD(9000010.02,.07,0),U,2)[405.1

               SET X=$$VAL^XBDIQ1(405.1,$PIECE(APCDEREC,U,7),9999999.1)

 +4        IF X=""

               SET APCDE="E031"

               DO ERR

DISP      ; Disposition Type-CP 60 

 +1        SET APCDDISP=""

 +2        IF $PIECE(APCDEREC,U,6)=""

               SET APCDE="E034"

               DO ERR

               GOTO UCAUS

 +3        IF $PIECE(^DD(9000010.02,.06,0),U,2)[42.2

               SET APCDDISP=$$VAL^XBDIQ1(42.2,$PIECE(APCDEREC,U,6),9999999.01)

 +4        IF $PIECE(^DD(9000010.02,.06,0),U,2)[405.1

               SET APCDDISP=$$VAL^XBDIQ1(405.1,$PIECE(APCDEREC,U,6),9999999.1)

 +5        IF $LENGTH(APCDDISP)'=1

               SET APCDE="E039"

               DO ERR

 +6       ;

 +7       ;

UCAUS     ; Underlying cause of death-CP 76-80.

 +1        IF APCDDISP<4

               GOTO XIT

 +2        IF '$DATA(^AUPNPAT(AUPNPAT,11))

               SET APCDE="E602"

               DO ERR

               GOTO XIT

 +3        SET APCDICDP=$PIECE(^AUPNPAT(AUPNPAT,11),U,14)

           IF APCDICDP=""

               SET APCDE="E030"

               DO ERR

               GOTO XIT

 +4        SET APCDICD=$$CODEC^ICDEX(80,APCDICDP)

 +5        KILL APCDE,APCDAGEE

 +6        DO ^APCDRICD

 +7        IF $DATA(APCDE)

               DO ERR

 +8       ;

 +9       ;

XIT       ; Clean up and exit

 +1        KILL APCDDISP,APCDICDP,APCDICD,APCDAGEE,APCDEREC,APCDE

 +2        QUIT 

ERR       ;

 +1        SET APCDE("FILE")=9000010.02

           SET APCDE("ENTRY")=APCDEDFN

 +2        DO ERR^APCDRV

 +3        QUIT