APCPHOS2.m

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