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
