APCDR08.m

APCDR08 ; IHS/CMI/LAB - V PROCEDURE REVIEW ;

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

 ;

 S APCDEREC=^AUPNVPRC(APCDEDFN,0)

OPCODE ; Operation Code-CP 94-97

 S APCDOPTR=$P(APCDEREC,U),APCDNPTR=$P(APCDEREC,U,4)

 I APCDOPTR="" S APCDE="E007" D ERR G XIT

 I '$D(^ICD0(APCDOPTR,0)) S APCDE="E007" D ERR G XIT

 S APCDOP=$$CODEC^ICDEX(80.1,APCDOPTR)

 I APCDOP=.9999!(APCDOP="ZZZ999") S APCDE="E032" D ERR G XIT

 ;I $L($P(APCDOP,".",2))>2 S APCDE="E003" D ERR G XIT

 I $P($$ICDOP^ICDEX(APCDOPTR,$$VD^APCLV(APCDVSIT),,"I"),U,11)]"",AUPNSEX'=$P($$ICDOP^ICDEX(APCDOPTR,$$VD^APCLV(APCDVSIT),,"I"),U,11) S APCDE="E043" D ERR G XIT

 I $$VERSION^XPDUTL("BCSV")]"" G OPNARR  ;no age edits in csv

 G:'$D(^ICD0($P(APCDEREC,U),9999999)) OPNARR

 I $P(^ICD0($P(APCDEREC,U),9999999),U,2)]"",($P(^ICD0($P(APCDEREC,U),9999999),U,2)<AUPNDAYS),'$D(APCDACC) S APCDE="E036" D ERR G XIT

 I $P(^ICD0($P(APCDEREC,U),9999999),U)]"",($P(^ICD0($P(APCDEREC,U),9999999),U)>AUPNDAYS),'$D(APCDACC) S APCDE="E036" D ERR G XIT

 ;

OPNARR ; Operation Narrative-CP 50-93

 I APCDNPTR="" S APCDE="E006" D ERR G XIT

 I '$D(^AUTNPOV(APCDNPTR,0)) S APCDE="E006" D ERR G XIT

 ;

DXPRFM ; Diagnosis for which Operation Performed. Char Pos 98-102.

 G:$P(APCDVREC,U,7)'="H" XIT

 S APCDICD="",APCDICDP=$P(APCDEREC,U,5) I APCDICDP="" S APCDE="E044" D ERR G XIT

 I '$D(^ICD9(APCDICDP,0)) S APCDE="E044" D ERR G XIT

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

 K APCDE,APCDAGEE

 D ^APCDRICD

 I $D(APCDE) D ERR G XIT

 ;

XIT ; Clean up and exit

 K APCDEREC,APCDNPTR,APCDOPTR,APCDICD,APCDAGEE,APCDICDP,APCDE,APCDOP

 Q

ERR ;

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

 D ERR^APCDRV

 Q

APCDR08   ; IHS/CMI/LAB - V PROCEDURE REVIEW ;

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

 +2       ;

 +3        SET APCDEREC=^AUPNVPRC(APCDEDFN,0)

OPCODE    ; Operation Code-CP 94-97

 +1        SET APCDOPTR=$PIECE(APCDEREC,U)

           SET APCDNPTR=$PIECE(APCDEREC,U,4)

 +2        IF APCDOPTR=""

               SET APCDE="E007"

               DO ERR

               GOTO XIT

 +3        IF '$DATA(^ICD0(APCDOPTR,0))

               SET APCDE="E007"

               DO ERR

               GOTO XIT

 +4        SET APCDOP=$$CODEC^ICDEX(80.1,APCDOPTR)

 +5        IF APCDOP=.9999!(APCDOP="ZZZ999")

               SET APCDE="E032"

               DO ERR

               GOTO XIT

 +6       ;I $L($P(APCDOP,".",2))>2 S APCDE="E003" D ERR G XIT

 +7        IF $PIECE($$ICDOP^ICDEX(APCDOPTR,$$VD^APCLV(APCDVSIT),,"I"),U,11)]""

               IF AUPNSEX'=$PIECE($$ICDOP^ICDEX(APCDOPTR,$$VD^APCLV(APCDVSIT),,"I"),U,11)

                   SET APCDE="E043"

                   DO ERR

                   GOTO XIT

 +8       ;no age edits in csv

           IF $$VERSION^XPDUTL("BCSV")]""

               GOTO OPNARR

 +9        IF '$DATA(^ICD0($PIECE(APCDEREC,U),9999999))

               GOTO OPNARR

 +10       IF $PIECE(^ICD0($PIECE(APCDEREC,U),9999999),U,2)]""

               IF ($PIECE(^ICD0($PIECE(APCDEREC,U),9999999),U,2)<AUPNDAYS)

                   IF '$DATA(APCDACC)

                       SET APCDE="E036"

                       DO ERR

                       GOTO XIT

 +11       IF $PIECE(^ICD0($PIECE(APCDEREC,U),9999999),U)]""

               IF ($PIECE(^ICD0($PIECE(APCDEREC,U),9999999),U)>AUPNDAYS)

                   IF '$DATA(APCDACC)

                       SET APCDE="E036"

                       DO ERR

                       GOTO XIT

 +12      ;

OPNARR    ; Operation Narrative-CP 50-93

 +1        IF APCDNPTR=""

               SET APCDE="E006"

               DO ERR

               GOTO XIT

 +2        IF '$DATA(^AUTNPOV(APCDNPTR,0))

               SET APCDE="E006"

               DO ERR

               GOTO XIT

 +3       ;

DXPRFM    ; Diagnosis for which Operation Performed. Char Pos 98-102.

 +1        IF $PIECE(APCDVREC,U,7)'="H"

               GOTO XIT

 +2        SET APCDICD=""

           SET APCDICDP=$PIECE(APCDEREC,U,5)

           IF APCDICDP=""

               SET APCDE="E044"

               DO ERR

               GOTO XIT

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

               SET APCDE="E044"

               DO ERR

               GOTO XIT

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

 +5        KILL APCDE,APCDAGEE

 +6        DO ^APCDRICD

 +7        IF $DATA(APCDE)

               DO ERR

               GOTO XIT

 +8       ;

XIT       ; Clean up and exit

 +1        KILL APCDEREC,APCDNPTR,APCDOPTR,APCDICD,APCDAGEE,APCDICDP,APCDE,APCDOP

 +2        QUIT 

ERR       ;

 +1        SET APCDE("FILE")=9000010.08

           SET APCDE("ENTRY")=APCDEDFN

 +2        DO ERR^APCDRV

 +3        QUIT