- APCPHOSP ; IHS/TUCSON/LAB - VISIT REVIEW - HOSPITALIZATIONS AUGUST 14, 1992 ; [ 04/03/98 08:39 AM ]
- ;;2.0;IHS PCC DATA EXTRACTION SYSTEM;;APR 03, 1998
- CHKHOSP ;
- Q:"C"[$P(APCPV("V REC"),U,3)
- I '$D(^AUPNVINP("AD",APCP("V DFN"))) S APCPE("ERROR")="E302" G XIT
- S APCPH("VINP PTR")=$O(^AUPNVINP("AD",APCP("V DFN"),""))
- I $P(^AUPNVINP(APCPH("VINP PTR"),0),U,15) S APCPE("ERROR")="E337" G XIT
- D GETACC^APCPHOS2
- D GETTS
- G:$D(APCPE("ERROR")) XIT
- D GETPOVS
- I '$D(APCPH("POV","P")) S APCPE("ERROR")="E300" G XIT
- I APCP3>1 S APCPE("ERROR")="E301" G XIT
- G:$D(APCPE("ERROR")) XIT
- D ^APCPHOS2
- G:$D(APCPE("ERROR")) XIT
- D CHECKPVS
- I $D(APCPE) S APCPE("FILE")=9000010,APCPE("EDFN")=APCP("V DFN") G XIT
- D ^APCPHOS1
- XIT ;
- K APCP1,APCP2,APCP3,APCPSC,APCPPREC
- Q
- GETTS ;
- S APCPH("VINP PTR")=$O(^AUPNVINP("AD",APCP("V DFN"),"")),APCPH("VINP REC")=^AUPNVINP(APCPH("VINP PTR"),0),APCPH("A TS CODE")=$P(APCPH("VINP REC"),U,4),APCPH("D TS CODE")=$P(APCPH("VINP REC"),U,5)
- I APCPH("A TS CODE")="" S APCPE("ERROR")="E303" Q
- I APCPH("D TS CODE")="" S APCPE("ERROR")="E304" Q
- S APCPH("A TS CODE")=$P(^DIC(45.7,APCPH("A TS CODE"),9999999),U),APCPH("D TS CODE")=$P(^DIC(45.7,APCPH("D TS CODE"),9999999),U)
- I APCPH("A TS CODE")="" S APCPE("ERROR")="E305"
- I APCPH("D TS CODE")="" S APCPE("ERROR")="E306"
- Q
- GETPOVS ;
- S (APCP1,APCP2,APCP3)=0 F S APCP2=$O(^AUPNVPOV("AD",APCP("V DFN"),APCP2)) Q:APCP2="" S APCP1=APCP1+1 D SETPOV
- Q
- SETPOV ;
- S APCPPREC=^AUPNVPOV(APCP2,0)
- S APCPSC=$P(APCPPREC,U,12) S:APCPSC="" APCPSC="S"
- I APCPSC="P" S APCP3=APCP3+1,APCPH("POV","P")=$P(^ICD9($P(APCPPREC,U),0),U)_"^"_$P(APCPPREC,U)_"^"_APCP2 Q
- S APCPH("POV",APCPSC,APCP1)=$P(^ICD9($P(APCPPREC,U),0),U)_"^"_$P(APCPPREC,U)_"^"_APCP2
- Q
- CHECKPVS ;
- C2 ;CERTAIN "V" CODES CANNOT BE PRIMARY DXS
- I $D(^APCDINPT(2,11,"AC",$P(APCPH("POV","P"),U))) S APCPE("ERROR")="E307" Q
- C1 ;IF PRIMARY DX IS A "V" CODE SECONDARY MUST BE "V" CODE ALSO
- ;WITH EXCEPTIONS
- I $E($P(APCPH("POV","P"),U))="V",'$D(^APCDINPT(1,11,"AC",$P(APCPH("POV","P"),U))) D
- .S APCP1=0 F S APCP1=$O(APCPH("POV","S",APCP1)) Q:APCP1'=+APCP1 D
- ..I $E($P(APCPH("POV","S",APCP1),U))'="V" S APCPE("ERROR")="E308"
- ..Q
- .Q
- Q:$D(APCPE("ERROR"))
- E1 ;CERTAIN CODES REQUIRE AN ACCEPT COMMAND
- I $D(^APCDINPT(8,11,"AC",$P(APCPH("POV","P"),U))),'$D(APCPV("ACC")) S APCPE("ERROR")="E309" Q
- S APCP1=0 F S APCP1=$O(APCPH("POV","S",APCP1)) Q:APCP1'=+APCP1 D E11
- Q:$D(APCPE("ERROR"))
- ;
- E2 ;IF CODE V30-V39 (.0) ADM SRV MUST BE NEWBORN
- I $D(^APCDINPT(4,11,"AC",$P(APCPH("POV","P"),U))),APCPH("A TS CODE")'="07" S APCPE("ERROR")="E311" Q
- I '$D(^APCDINPT(4,11,"AC",$P(APCPH("POV","P"),U))),APCPH("A TS CODE")="07" S APCPE("ERROR")="E331" Q
- E3 ;IF PRIMARY DX IS V30-V39(.1) ADM SRV MUST BE ,11
- I $D(^APCDINPT(3,11,"AC",$P(APCPH("POV","P"),U))),APCPH("A TS CODE")'=11 S APCPE("ERROR")="E312" Q
- E4 ;IF PRIM DX (V30-V39 (.0 OR ,.1)) AGE CANNOT BE > 3 DAYS
- I (($D(^APCDINPT(4,11,"AC",$P(APCPH("POV","P"),U))))!($D(^APCDINPT(3,11,"AC",$P(APCPH("POV","P"),U))))),AUPNDAYS>3 S APCPE("ERROR")="E313" Q
- Q
- E11 ;
- I $D(^APCDINPT(8,11,"AC",$P(APCPH("POV","S",APCP1),U))),'$D(APCPV("ACC")) S APCPE("ERROR")="E309" Q
- Q
- APCPHOSP ; IHS/TUCSON/LAB - VISIT REVIEW - HOSPITALIZATIONS AUGUST 14, 1992 ; [ 04/03/98 08:39 AM ]
- +1 ;;2.0;IHS PCC DATA EXTRACTION SYSTEM;;APR 03, 1998
- CHKHOSP ;
- +1 IF "C"[$PIECE(APCPV("V REC"),U,3)
- QUIT
- +2 IF '$DATA(^AUPNVINP("AD",APCP("V DFN")))
- SET APCPE("ERROR")="E302"
- GOTO XIT
- +3 SET APCPH("VINP PTR")=$ORDER(^AUPNVINP("AD",APCP("V DFN"),""))
- +4 IF $PIECE(^AUPNVINP(APCPH("VINP PTR"),0),U,15)
- SET APCPE("ERROR")="E337"
- GOTO XIT
- +5 DO GETACC^APCPHOS2
- +6 DO GETTS
- +7 IF $DATA(APCPE("ERROR"))
- GOTO XIT
- +8 DO GETPOVS
- +9 IF '$DATA(APCPH("POV","P"))
- SET APCPE("ERROR")="E300"
- GOTO XIT
- +10 IF APCP3>1
- SET APCPE("ERROR")="E301"
- GOTO XIT
- +11 IF $DATA(APCPE("ERROR"))
- GOTO XIT
- +12 DO ^APCPHOS2
- +13 IF $DATA(APCPE("ERROR"))
- GOTO XIT
- +14 DO CHECKPVS
- +15 IF $DATA(APCPE)
- SET APCPE("FILE")=9000010
- SET APCPE("EDFN")=APCP("V DFN")
- GOTO XIT
- +16 DO ^APCPHOS1
- XIT ;
- +1 KILL APCP1,APCP2,APCP3,APCPSC,APCPPREC
- +2 QUIT
- GETTS ;
- +1 SET APCPH("VINP PTR")=$ORDER(^AUPNVINP("AD",APCP("V DFN"),""))
- SET APCPH("VINP REC")=^AUPNVINP(APCPH("VINP PTR"),0)
- SET APCPH("A TS CODE")=$PIECE(APCPH("VINP REC"),U,4)
- SET APCPH("D TS CODE")=$PIECE(APCPH("VINP REC"),U,5)
- +2 IF APCPH("A TS CODE")=""
- SET APCPE("ERROR")="E303"
- QUIT
- +3 IF APCPH("D TS CODE")=""
- SET APCPE("ERROR")="E304"
- QUIT
- +4 SET APCPH("A TS CODE")=$PIECE(^DIC(45.7,APCPH("A TS CODE"),9999999),U)
- SET APCPH("D TS CODE")=$PIECE(^DIC(45.7,APCPH("D TS CODE"),9999999),U)
- +5 IF APCPH("A TS CODE")=""
- SET APCPE("ERROR")="E305"
- +6 IF APCPH("D TS CODE")=""
- SET APCPE("ERROR")="E306"
- +7 QUIT
- GETPOVS ;
- +1 SET (APCP1,APCP2,APCP3)=0
- FOR
- SET APCP2=$ORDER(^AUPNVPOV("AD",APCP("V DFN"),APCP2))
- IF APCP2=""
- QUIT
- SET APCP1=APCP1+1
- DO SETPOV
- +2 QUIT
- SETPOV ;
- +1 SET APCPPREC=^AUPNVPOV(APCP2,0)
- +2 SET APCPSC=$PIECE(APCPPREC,U,12)
- IF APCPSC=""
- SET APCPSC="S"
- +3 IF APCPSC="P"
- SET APCP3=APCP3+1
- SET APCPH("POV","P")=$PIECE(^ICD9($PIECE(APCPPREC,U),0),U)_"^"_$PIECE(APCPPREC,U)_"^"_APCP2
- QUIT
- +4 SET APCPH("POV",APCPSC,APCP1)=$PIECE(^ICD9($PIECE(APCPPREC,U),0),U)_"^"_$PIECE(APCPPREC,U)_"^"_APCP2
- +5 QUIT
- CHECKPVS ;
- C2 ;CERTAIN "V" CODES CANNOT BE PRIMARY DXS
- +1 IF $DATA(^APCDINPT(2,11,"AC",$PIECE(APCPH("POV","P"),U)))
- SET APCPE("ERROR")="E307"
- QUIT
- C1 ;IF PRIMARY DX IS A "V" CODE SECONDARY MUST BE "V" CODE ALSO
- +1 ;WITH EXCEPTIONS
- +2 IF $EXTRACT($PIECE(APCPH("POV","P"),U))="V"
- IF '$DATA(^APCDINPT(1,11,"AC",$PIECE(APCPH("POV","P"),U)))
- Begin DoDot:1
- +3 SET APCP1=0
- FOR
- SET APCP1=$ORDER(APCPH("POV","S",APCP1))
- IF APCP1'=+APCP1
- QUIT
- Begin DoDot:2
- +4 IF $EXTRACT($PIECE(APCPH("POV","S",APCP1),U))'="V"
- SET APCPE("ERROR")="E308"
- +5 QUIT
- End DoDot:2
- +6 QUIT
- End DoDot:1
- +7 IF $DATA(APCPE("ERROR"))
- QUIT
- E1 ;CERTAIN CODES REQUIRE AN ACCEPT COMMAND
- +1 IF $DATA(^APCDINPT(8,11,"AC",$PIECE(APCPH("POV","P"),U)))
- IF '$DATA(APCPV("ACC"))
- SET APCPE("ERROR")="E309"
- QUIT
- +2 SET APCP1=0
- FOR
- SET APCP1=$ORDER(APCPH("POV","S",APCP1))
- IF APCP1'=+APCP1
- QUIT
- DO E11
- +3 IF $DATA(APCPE("ERROR"))
- QUIT
- +4 ;
- E2 ;IF CODE V30-V39 (.0) ADM SRV MUST BE NEWBORN
- +1 IF $DATA(^APCDINPT(4,11,"AC",$PIECE(APCPH("POV","P"),U)))
- IF APCPH("A TS CODE")'="07"
- SET APCPE("ERROR")="E311"
- QUIT
- +2 IF '$DATA(^APCDINPT(4,11,"AC",$PIECE(APCPH("POV","P"),U)))
- IF APCPH("A TS CODE")="07"
- SET APCPE("ERROR")="E331"
- QUIT
- E3 ;IF PRIMARY DX IS V30-V39(.1) ADM SRV MUST BE ,11
- +1 IF $DATA(^APCDINPT(3,11,"AC",$PIECE(APCPH("POV","P"),U)))
- IF APCPH("A TS CODE")'=11
- SET APCPE("ERROR")="E312"
- QUIT
- E4 ;IF PRIM DX (V30-V39 (.0 OR ,.1)) AGE CANNOT BE > 3 DAYS
- +1 IF (($DATA(^APCDINPT(4,11,"AC",$PIECE(APCPH("POV","P"),U))))!($DATA(^APCDINPT(3,11,"AC",$PIECE(APCPH("POV","P"),U)))))
- IF AUPNDAYS>3
- SET APCPE("ERROR")="E313"
- QUIT
- +2 QUIT
- E11 ;
- +1 IF $DATA(^APCDINPT(8,11,"AC",$PIECE(APCPH("POV","S",APCP1),U)))
- IF '$DATA(APCPV("ACC"))
- SET APCPE("ERROR")="E309"
- QUIT
- +2 QUIT
