APCDRVH.m

APCDRVH ; IHS/CMI/LAB - VISIT REVIEW HOSPITALIZATIONS ;

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

CHKHOSP ;CHECK HOSPITALIZATION EDITS

 S APCDVREC=^AUPNVSIT(APCDVSIT,0)

 Q:"C"[$P(APCDVREC,U,3)

 I '$D(^AUPNVINP("AD",APCDVSIT)) S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E302" D ERR G XIT

 S APCDVINP=$O(^AUPNVINP("AD",APCDVSIT,"")),APCDVINR=^AUPNVINP(APCDVINP,0)

 I $P(APCDVINR,U,12)="" S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E338" D ERR G XIT

 D GETTS

 Q:APCDTS=""

 Q:APCDDS=""

 D GETPOVS

 I '$D(APCDPOV("P")) S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E300" D ERR G XIT

 I APCD3>1 S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E301" D ERR G XIT

 D ^APCDRVH2

 D CHECKPVS

 D ^APCDRVH1

XIT ;

 K APCDTS,APCDVINR,APCDDS,APCDIACC,APCD1,APCD2,APCD3,APCDPREC,APCDSC,APCDICD9,APCDPOV,APCDACC,APCDDUPE,APCDDXP,APCDACCO,APCDDUPO,APCDOPP,APCDDX,APCDPX,APCDFOUN,APCDOPP,APCDOPC,APCDDXP,APCDDXC,APCDDXOP,APCDOPDX

 K APCDE,APCDPOV,APCDVINP,APCDADM,APCDDIS,APCDVREC

 Q

ERR ;

 D ERR^APCDRV

 Q

GETTS ;

 S APCDTS=$P(APCDVINR,U,4),APCDDS=$P(APCDVINR,U,5)

 I APCDTS="" S APCDE("FILE")=9000010.02,APCDE("ENTRY")=APCDVINP,APCDE="E303" D ERR Q

 I APCDDS="" S APCDE("FILE")=9000010.02,APCDE("ENTRY")=APCDVINP,APCDE="E304" D ERR Q

 S APCDTS=$P(^DIC(45.7,APCDTS,9999999),U),APCDDS=$P(^DIC(45.7,APCDDS,9999999),U)

 I APCDTS="" S APCDE("FILE")=9000010.02,APCDE("ENTRY")=APCDVINP,APCDE="E305" D ERR

 I APCDDS="" S APCDE("FILE")=9000010.02,APCDE("ENTRY")=APCDVINP,APCDE="E306" D ERR

 Q

GETPOVS ;

 S (APCD1,APCD2,APCD3)=0 F  S APCD2=$O(^AUPNVPOV("AD",APCDVSIT,APCD2)) Q:APCD2=""  S APCD1=APCD1+1 D SETPOV

 Q

SETPOV ;

 S APCDPREC=^AUPNVPOV(APCD2,0),APCDSC=$P(APCDPREC,U,12) S:APCDSC="" APCDSC="S"

 I APCDSC="P" S APCD3=APCD3+1,APCDPOV("P")=$$ICDDX^ICDEX($P(APCDPREC,U))_"^"_$P(APCDPREC,U)_"^"_APCD2 Q

 S APCDPOV(APCDSC,APCD1)=$$ICDDX^ICDEX($P(APCDPREC,U))_"^"_$P(APCDPREC,U)_"^"_APCD2

 Q

 ;

 ;

CHECKPVS ;

 Q:$D(APCDACC)

C2 ;CERTAIN "V" CODES CANNOT BE PRIMARY DXS

 ;I $D(^APCDINPT(2,11,"AC",$P(APCDPOV("P"),U))) S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E307" D ERR Q

C1 ;IF PRIMARY DX IS A "V" CODE SECONDARY MUST BE "V" CODE ALSO

 ;WITH EXCEPTIONS

 ;I $E($P(APCDPOV("P"),U))="V",'$D(^APCDINPT(1,11,"AC",$P(APCDPOV("P"),U))) D

 ;. S APCD1=0 F  S APCD1=$O(APCDPOV("S",APCD1)) Q:APCD1'=+APCD1  D

 ;.. ;I $E($P(APCDPOV("S",APCD1),U))'="V" S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E308" D ERR

E1 ;CERTAIN CODES REQUIRE AN ACCEPT COMMAND

 ;I $D(^APCDINPT(8,11,"AC",$P(APCDPOV("P"),U))) D E1W

 ;S APCD1=0 F  S APCD1=$O(APCDPOV("S",APCD1)) Q:APCD1'=+APCD1   D E11

 ;

E2 ;IF CODE V30-V39 (.0) ADM SRV MUST BE NEWBORN

 I $D(^APCDINPT(4,11,"AC",$P(APCDPOV("P"),U))),APCDTS'="07" S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E311" D ERR Q

 ;I '$D(^APCDINPT(4,11,"AC",$P(APCDPOV("P"),U))),APCDTS="07" S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E331" D ERR Q

E3 ;IF PRIMARY DX IS V30-V39(.1) ADM SRV MUST BE ,11

 ;COMMENTED OUT BECAUSE NO EVIDENCE OF THIS EDIT IN KAUFMANN'S 

 ;MEMO OF JAN, 1990.

E4 ;IF PRIM DX (V30-V39 (.0 OR ,.1)) AGE CANNOT BE > 3 DAYS

 I (($D(^APCDINPT(4,11,"AC",$P(APCDPOV("P"),U))))!($D(^APCDINPT(3,11,"AC",$P(APCDPOV("P"),U))))),AUPNDAYS>3 S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E313" D ERR Q

 Q

E11 ;CHECK SECONDARY FOR REQUIRED ACCEPT COMMAND/INVALID SECONDARY PVS

 ;I $D(^APCDINPT(8,11,"AC",$P(APCDPOV("S",APCD1),U))) D E1W

 Q

E1W ;

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

 Q

 ;

APCDRVH   ; IHS/CMI/LAB - VISIT REVIEW HOSPITALIZATIONS ;

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

CHKHOSP   ;CHECK HOSPITALIZATION EDITS

 +1        SET APCDVREC=^AUPNVSIT(APCDVSIT,0)

 +2        IF "C"[$PIECE(APCDVREC,U,3)

               QUIT 

 +3        IF '$DATA(^AUPNVINP("AD",APCDVSIT))

               SET APCDE("FILE")=9000010

               SET APCDE("ENTRY")=APCDVSIT

               SET APCDE="E302"

               DO ERR

               GOTO XIT

 +4        SET APCDVINP=$ORDER(^AUPNVINP("AD",APCDVSIT,""))

           SET APCDVINR=^AUPNVINP(APCDVINP,0)

 +5        IF $PIECE(APCDVINR,U,12)=""

               SET APCDE("FILE")=9000010

               SET APCDE("ENTRY")=APCDVSIT

               SET APCDE="E338"

               DO ERR

               GOTO XIT

 +6        DO GETTS

 +7        IF APCDTS=""

               QUIT 

 +8        IF APCDDS=""

               QUIT 

 +9        DO GETPOVS

 +10       IF '$DATA(APCDPOV("P"))

               SET APCDE("FILE")=9000010

               SET APCDE("ENTRY")=APCDVSIT

               SET APCDE="E300"

               DO ERR

               GOTO XIT

 +11       IF APCD3>1

               SET APCDE("FILE")=9000010

               SET APCDE("ENTRY")=APCDVSIT

               SET APCDE="E301"

               DO ERR

               GOTO XIT

 +12       DO ^APCDRVH2

 +13       DO CHECKPVS

 +14       DO ^APCDRVH1

XIT       ;

 +1        KILL APCDTS,APCDVINR,APCDDS,APCDIACC,APCD1,APCD2,APCD3,APCDPREC,APCDSC,APCDICD9,APCDPOV,APCDACC,APCDDUPE,APCDDXP,APCDACCO,APCDDUPO,APCDOPP,APCDDX,APCDPX,APCDFOUN,APCDOPP,APCDOPC,APCDDXP,APCDDXC,APCDDXOP,APCDOPDX

 +2        KILL APCDE,APCDPOV,APCDVINP,APCDADM,APCDDIS,APCDVREC

 +3        QUIT 

ERR       ;

 +1        DO ERR^APCDRV

 +2        QUIT 

GETTS     ;

 +1        SET APCDTS=$PIECE(APCDVINR,U,4)

           SET APCDDS=$PIECE(APCDVINR,U,5)

 +2        IF APCDTS=""

               SET APCDE("FILE")=9000010.02

               SET APCDE("ENTRY")=APCDVINP

               SET APCDE="E303"

               DO ERR

               QUIT 

 +3        IF APCDDS=""

               SET APCDE("FILE")=9000010.02

               SET APCDE("ENTRY")=APCDVINP

               SET APCDE="E304"

               DO ERR

               QUIT 

 +4        SET APCDTS=$PIECE(^DIC(45.7,APCDTS,9999999),U)

           SET APCDDS=$PIECE(^DIC(45.7,APCDDS,9999999),U)

 +5        IF APCDTS=""

               SET APCDE("FILE")=9000010.02

               SET APCDE("ENTRY")=APCDVINP

               SET APCDE="E305"

               DO ERR

 +6        IF APCDDS=""

               SET APCDE("FILE")=9000010.02

               SET APCDE("ENTRY")=APCDVINP

               SET APCDE="E306"

               DO ERR

 +7        QUIT 

GETPOVS   ;

 +1        SET (APCD1,APCD2,APCD3)=0

           FOR 

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

               IF APCD2=""

                   QUIT 

               SET APCD1=APCD1+1

               DO SETPOV

 +2        QUIT 

SETPOV    ;

 +1        SET APCDPREC=^AUPNVPOV(APCD2,0)

           SET APCDSC=$PIECE(APCDPREC,U,12)

           IF APCDSC=""

               SET APCDSC="S"

 +2        IF APCDSC="P"

               SET APCD3=APCD3+1

               SET APCDPOV("P")=$$ICDDX^ICDEX($PIECE(APCDPREC,U))_"^"_$PIECE(APCDPREC,U)_"^"_APCD2

               QUIT 

 +3        SET APCDPOV(APCDSC,APCD1)=$$ICDDX^ICDEX($PIECE(APCDPREC,U))_"^"_$PIECE(APCDPREC,U)_"^"_APCD2

 +4        QUIT 

 +5       ;

 +6       ;

CHECKPVS  ;

 +1        IF $DATA(APCDACC)

               QUIT 

C2        ;CERTAIN "V" CODES CANNOT BE PRIMARY DXS

 +1       ;I $D(^APCDINPT(2,11,"AC",$P(APCDPOV("P"),U))) S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E307" D ERR Q

C1        ;IF PRIMARY DX IS A "V" CODE SECONDARY MUST BE "V" CODE ALSO

 +1       ;WITH EXCEPTIONS

 +2       ;I $E($P(APCDPOV("P"),U))="V",'$D(^APCDINPT(1,11,"AC",$P(APCDPOV("P"),U))) D

 +3       ;. S APCD1=0 F  S APCD1=$O(APCDPOV("S",APCD1)) Q:APCD1'=+APCD1  D

 +4       ;.. ;I $E($P(APCDPOV("S",APCD1),U))'="V" S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E308" D ERR

E1        ;CERTAIN CODES REQUIRE AN ACCEPT COMMAND

 +1       ;I $D(^APCDINPT(8,11,"AC",$P(APCDPOV("P"),U))) D E1W

 +2       ;S APCD1=0 F  S APCD1=$O(APCDPOV("S",APCD1)) Q:APCD1'=+APCD1   D E11

 +3       ;

E2        ;IF CODE V30-V39 (.0) ADM SRV MUST BE NEWBORN

 +1        IF $DATA(^APCDINPT(4,11,"AC",$PIECE(APCDPOV("P"),U)))

               IF APCDTS'="07"

                   SET APCDE("FILE")=9000010

                   SET APCDE("ENTRY")=APCDVSIT

                   SET APCDE="E311"

                   DO ERR

                   QUIT 

 +2       ;I '$D(^APCDINPT(4,11,"AC",$P(APCDPOV("P"),U))),APCDTS="07" S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E331" D ERR Q

E3        ;IF PRIMARY DX IS V30-V39(.1) ADM SRV MUST BE ,11

 +1       ;COMMENTED OUT BECAUSE NO EVIDENCE OF THIS EDIT IN KAUFMANN'S 

 +2       ;MEMO OF JAN, 1990.

E4        ;IF PRIM DX (V30-V39 (.0 OR ,.1)) AGE CANNOT BE > 3 DAYS

 +1        IF (($DATA(^APCDINPT(4,11,"AC",$PIECE(APCDPOV("P"),U))))!($DATA(^APCDINPT(3,11,"AC",$PIECE(APCDPOV("P"),U)))))

               IF AUPNDAYS>3

                   SET APCDE("FILE")=9000010

                   SET APCDE("ENTRY")=APCDVSIT

                   SET APCDE="E313"

                   DO ERR

                   QUIT 

 +2        QUIT 

E11       ;CHECK SECONDARY FOR REQUIRED ACCEPT COMMAND/INVALID SECONDARY PVS

 +1       ;I $D(^APCDINPT(8,11,"AC",$P(APCDPOV("S",APCD1),U))) D E1W

 +2        QUIT 

E1W       ;

 +1       ;S APCDE("FILE")=9000010,APCDE("ENTRY")=APCDVSIT,APCDE="E309" D ERR

 +2        QUIT 

 +3       ;