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