- APCPHOS2 ; IHS/TUCSON/LAB - CONT. HOSP REVIEW AUGUST 14, 1992 ; [ 04/03/98 08:39 AM ]
- ;;2.0;IHS PCC DATA EXTRACTION SYSTEM;;APR 03, 1998
- START ;
- D CHKADM
- I $D(APCPE("ERROR")) S APCPE("FILE")=9000010.02,APCPE("EDFN")=APCPH("VINP PTR") Q
- D CHKTS
- I $D(APCPE("ERROR")) S APCPE("FILE")=9000010.02,APCPE("EDFN")=APCPH("VINP PTR") Q
- D CHKAGE
- Q:$D(APCPE("ERROR"))
- D DATES
- Q:$D(APCPE("ERROR"))
- XIT ;
- Q
- ;
- ;
- CHKTS ;
- I APCPH("A TS CODE")="07",AUPNDAYS]"",AUPNDAYS>1 S APCPE("ERROR")="E318" Q
- I APCPH("A TS CODE")="11",AUPNDAYS]"",AUPNDAYS>5479 S APCPE("ERROR")="E319" Q
- I APCPH("A TS CODE")="05"!(APCPH("A TS CODE")="08"),AUPNSEX'="F" S APCPE("ERROR")="E320",APCPE("FILE")="9000010.02,",APCPV("EDFN")=APCPH("VINP PTR") Q
- I APCPH("A TS CODE")="08",AUPNDAYS]"",(AUPNDAYS<3652!(AUPNDAYS>20088)),'$D(APCPV("ACC")) S APCPE("ERROR")="E321" Q
- I APCPH("D TS CODE")="05"!(APCPH("D TS CODE")="08"),AUPNSEX'="F" S APCPE("ERROR")="E324",APCPE("FILE")="9000010.02,",APCPV("EDFN")=APCPH("VINP PTR") Q
- I APCPH("D TS CODE")="08",AUPNDAYS]"",(AUPNDAYS<3652!(AUPNDAYS>20088)),'$D(APCPV("ACC")) S APCPE("ERROR")="E325" Q
- Q
- DATES ;
- S X1=$P(APCPH("VINP REC"),U),X2=$P(APCPV("V REC"),U) D ^%DTC I X<0 S APCPE("ERROR")="E326" Q
- I X>99,'$D(APCPV("ACC")) S APCPE("ERROR")="E327" Q
- Q
- CHKAGE ;
- Q:$D(APCPV("ACC"))
- Q:AUPNDAYS>5
- I $E($P(APCPH("POV","P"),U),1,2)'="V3" S APCPE("ERROR")="E328" Q
- Q
- CHKADM ;check admission date
- S APCPH("DISCH DATE")=$P($P(APCPH("VINP REC"),U),"."),APCPH("ADM DATE")=$P($P(APCPV("V REC"),U),".")
- I APCPH("DISCH DATE")<APCPH("ADM DATE") S APCPE("ERROR")="E326" Q
- I AUPNDOB>APCPH("ADM DATE") S APCPE("ERROR")="E329" Q
- Q:APCPH("ADM DATE")'=AUPNDOB
- Q:$D(APCPV("ACC"))
- I $E($P(APCPH("POV","P"),U),1,2)'="V3" S APCPE("ERROR")="E330" Q
- Q
- ;
- GETACC ;EP - get accept command if there is one and save variable
- K APCPV("ACC")
- ;$O THRU V POV'S FOR ACCEPT
- S APCPH(2)=0 F S APCPH(2)=$O(^AUPNVPOV("AD",APCP("V DFN"),APCPH(2))) Q:APCPH(2)="" I $P(^AUPNVPOV(APCPH(2),0),U,14)]"" S APCPV("ACC")="ACC"
- Q:$D(APCPV("ACC"))
- ;$O THRU V PROCEDURES FOR ACCEPT
- S APCPH(2)=0 F S APCPH(2)=$O(^AUPNVPRC("AD",APCP("V DFN"),APCPH(2))) Q:APCPH(2)="" I $P(^AUPNVPRC(APCPH(2),0),U,9)]"" S APCPV("ACC")="ACC"
- Q:$D(APCPV("ACC"))
- S APCPH(1)=$O(^AUPNVINP("AD",APCP("V DFN"),""))
- I $P(^AUPNVINP(APCPH(1),0),U,14)]"" S APCPV("ACC")="ACC"
- Q
- APCPHOS2 ; IHS/TUCSON/LAB - CONT. HOSP REVIEW AUGUST 14, 1992 ; [ 04/03/98 08:39 AM ]
- +1 ;;2.0;IHS PCC DATA EXTRACTION SYSTEM;;APR 03, 1998
- START ;
- +1 DO CHKADM
- +2 IF $DATA(APCPE("ERROR"))
- SET APCPE("FILE")=9000010.02
- SET APCPE("EDFN")=APCPH("VINP PTR")
- QUIT
- +3 DO CHKTS
- +4 IF $DATA(APCPE("ERROR"))
- SET APCPE("FILE")=9000010.02
- SET APCPE("EDFN")=APCPH("VINP PTR")
- QUIT
- +5 DO CHKAGE
- +6 IF $DATA(APCPE("ERROR"))
- QUIT
- +7 DO DATES
- +8 IF $DATA(APCPE("ERROR"))
- QUIT
- XIT ;
- +1 QUIT
- +2 ;
- +3 ;
- CHKTS ;
- +1 IF APCPH("A TS CODE")="07"
- IF AUPNDAYS]""
- IF AUPNDAYS>1
- SET APCPE("ERROR")="E318"
- QUIT
- +2 IF APCPH("A TS CODE")="11"
- IF AUPNDAYS]""
- IF AUPNDAYS>5479
- SET APCPE("ERROR")="E319"
- QUIT
- +3 IF APCPH("A TS CODE")="05"!(APCPH("A TS CODE")="08")
- IF AUPNSEX'="F"
- SET APCPE("ERROR")="E320"
- SET APCPE("FILE")="9000010.02,"
- SET APCPV("EDFN")=APCPH("VINP PTR")
- QUIT
- +4 IF APCPH("A TS CODE")="08"
- IF AUPNDAYS]""
- IF (AUPNDAYS<3652!(AUPNDAYS>20088))
- IF '$DATA(APCPV("ACC"))
- SET APCPE("ERROR")="E321"
- QUIT
- +5 IF APCPH("D TS CODE")="05"!(APCPH("D TS CODE")="08")
- IF AUPNSEX'="F"
- SET APCPE("ERROR")="E324"
- SET APCPE("FILE")="9000010.02,"
- SET APCPV("EDFN")=APCPH("VINP PTR")
- QUIT
- +6 IF APCPH("D TS CODE")="08"
- IF AUPNDAYS]""
- IF (AUPNDAYS<3652!(AUPNDAYS>20088))
- IF '$DATA(APCPV("ACC"))
- SET APCPE("ERROR")="E325"
- QUIT
- +7 QUIT
- DATES ;
- +1 SET X1=$PIECE(APCPH("VINP REC"),U)
- SET X2=$PIECE(APCPV("V REC"),U)
- DO ^%DTC
- IF X<0
- SET APCPE("ERROR")="E326"
- QUIT
- +2 IF X>99
- IF '$DATA(APCPV("ACC"))
- SET APCPE("ERROR")="E327"
- QUIT
- +3 QUIT
- CHKAGE ;
- +1 IF $DATA(APCPV("ACC"))
- QUIT
- +2 IF AUPNDAYS>5
- QUIT
- +3 IF $EXTRACT($PIECE(APCPH("POV","P"),U),1,2)'="V3"
- SET APCPE("ERROR")="E328"
- QUIT
- +4 QUIT
- CHKADM ;check admission date
- +1 SET APCPH("DISCH DATE")=$PIECE($PIECE(APCPH("VINP REC"),U),".")
- SET APCPH("ADM DATE")=$PIECE($PIECE(APCPV("V REC"),U),".")
- +2 IF APCPH("DISCH DATE")<APCPH("ADM DATE")
- SET APCPE("ERROR")="E326"
- QUIT
- +3 IF AUPNDOB>APCPH("ADM DATE")
- SET APCPE("ERROR")="E329"
- QUIT
- +4 IF APCPH("ADM DATE")'=AUPNDOB
- QUIT
- +5 IF $DATA(APCPV("ACC"))
- QUIT
- +6 IF $EXTRACT($PIECE(APCPH("POV","P"),U),1,2)'="V3"
- SET APCPE("ERROR")="E330"
- QUIT
- +7 QUIT
- +8 ;
- GETACC ;EP - get accept command if there is one and save variable
- +1 KILL APCPV("ACC")
- +2 ;$O THRU V POV'S FOR ACCEPT
- +3 SET APCPH(2)=0
- FOR
- SET APCPH(2)=$ORDER(^AUPNVPOV("AD",APCP("V DFN"),APCPH(2)))
- IF APCPH(2)=""
- QUIT
- IF $PIECE(^AUPNVPOV(APCPH(2),0),U,14)]""
- SET APCPV("ACC")="ACC"
- +4 IF $DATA(APCPV("ACC"))
- QUIT
- +5 ;$O THRU V PROCEDURES FOR ACCEPT
- +6 SET APCPH(2)=0
- FOR
- SET APCPH(2)=$ORDER(^AUPNVPRC("AD",APCP("V DFN"),APCPH(2)))
- IF APCPH(2)=""
- QUIT
- IF $PIECE(^AUPNVPRC(APCPH(2),0),U,9)]""
- SET APCPV("ACC")="ACC"
- +7 IF $DATA(APCPV("ACC"))
- QUIT
- +8 SET APCPH(1)=$ORDER(^AUPNVINP("AD",APCP("V DFN"),""))
- +9 IF $PIECE(^AUPNVINP(APCPH(1),0),U,14)]""
- SET APCPV("ACC")="ACC"
- +10 QUIT
