APCPDR21.m

APCPDR21 ; IHS/TUCSON/LAB - continuation of APCPDR2 AUGUST 14, 1992 ; [ 04/16/02 9:36 AM ]

 ;;2.0;IHS PCC DATA EXTRACTION SYSTEM;**1**;APR 03, 1998

 ;

DEM ;EP

 S APCPV("PATIENT DFN")=$P(APCPV("V REC"),U,5) I APCPV("PATIENT DFN")="" S APCPE("ERROR")="E104" Q

 S Y=APCPV("PATIENT DFN") D ^AUPNPAT

 S APCPV("PATIENT NAME")=$P(^DPT(APCPV("PATIENT DFN"),0),U)

 Q:APCPV("PATIENT NAME")["DEMO,PATIENT"  ;IHS/CMI/LAB - changed to "[" from "="

SEX ;

 I AUPNSEX="" S APCPE("ERROR")="E601" Q

DOB ;

 I AUPNDOB="" S APCPE("ERROR")="E600" Q

 S X2=AUPNDOB,X1=APCPV("V DATE") D ^%DTC S AUPNDAYS=X

 I '$D(^AUPNPAT(AUPNPAT,11)) S APCPE("ERROR")="E602" Q

COMM ;

 S APCPV("COMMX")=0,APCPV("COMMPX")="" F  S APCPV("COMMX")=$O(^AUPNPAT(AUPNPAT,51,APCPV("COMMX"))) Q:APCPV("COMMX")'=+APCPV("COMMX")  S APCPV("COMMPX")=APCPV("COMMX")

 I APCPV("COMMPX")="" S APCPE("ERROR")="E610" Q

 S APCPV("COMMPX")=$P(^AUPNPAT(AUPNPAT,51,APCPV("COMMPX"),0),U,3) I APCPV("COMMPX")="" S APCPE("ERROR")="E611" Q

 I '$D(^AUTTCOM(APCPV("COMMPX"),0)) S APCPE("ERROR")="E611" Q

 I APCPV("COMMPX")]"" S APCPV("COMM CODE")=$P(^AUTTCOM(APCPV("COMMPX"),0),U,8) I APCPV("COMM CODE")="" S APCPE("ERROR")="E612" Q

TRIBE ;

 S X=$P(^AUPNPAT(AUPNPAT,11),U,8) I X="" S APCPE("ERROR")="E605" D RESET Q

 I $P(^AUTTTRI(X,0),U,4)="Y" S APCPE("ERROR")="E607" D RESET Q

 S APCPV("TRIBE CODE")=$P(^AUTTTRI(X,0),U,2) I APCPV("TRIBE CODE")="" S APCPE("ERROR")="E608" Q

CHART S (APCPV("T-HASF"),APCPV("CHART"))=""

 I $D(^AUPNPAT(APCPV("PATIENT DFN"),41,APCPV("LOC DFN"),0))#2 S APCPV("T-HASF")=$P(^(0),U),APCPV("CHART")=$P(^(0),U,2)

 I APCPV("CHART")="" S APCPV("CHART")=999999 Q

 S APCPV("CHART")=$E("000000",1,6-$L(APCPV("CHART")))_APCPV("CHART")

 Q

 ;

RESET ;EP

 Q:$P(APCPV("V REC"),U,11)

 S DA=APCP("V DFN"),DIE="^AUPNVSIT(",DR=".13///"_DT D ^DIE K DA,DIU,DIE,DR,DIV

 Q

APCPDR21  ; IHS/TUCSON/LAB - continuation of APCPDR2 AUGUST 14, 1992 ; [ 04/16/02 9:36 AM ]

 +1       ;;2.0;IHS PCC DATA EXTRACTION SYSTEM;**1**;APR 03, 1998

 +2       ;

DEM       ;EP

 +1        SET APCPV("PATIENT DFN")=$PIECE(APCPV("V REC"),U,5)

           IF APCPV("PATIENT DFN")=""

               SET APCPE("ERROR")="E104"

               QUIT 

 +2        SET Y=APCPV("PATIENT DFN")

           DO ^AUPNPAT

 +3        SET APCPV("PATIENT NAME")=$PIECE(^DPT(APCPV("PATIENT DFN"),0),U)

 +4       ;IHS/CMI/LAB - changed to "[" from "="

           IF APCPV("PATIENT NAME")["DEMO,PATIENT"

               QUIT 

SEX       ;

 +1        IF AUPNSEX=""

               SET APCPE("ERROR")="E601"

               QUIT 

DOB       ;

 +1        IF AUPNDOB=""

               SET APCPE("ERROR")="E600"

               QUIT 

 +2        SET X2=AUPNDOB

           SET X1=APCPV("V DATE")

           DO ^%DTC

           SET AUPNDAYS=X

 +3        IF '$DATA(^AUPNPAT(AUPNPAT,11))

               SET APCPE("ERROR")="E602"

               QUIT 

COMM      ;

 +1        SET APCPV("COMMX")=0

           SET APCPV("COMMPX")=""

           FOR 

               SET APCPV("COMMX")=$ORDER(^AUPNPAT(AUPNPAT,51,APCPV("COMMX")))

               IF APCPV("COMMX")'=+APCPV("COMMX")

                   QUIT 

               SET APCPV("COMMPX")=APCPV("COMMX")

 +2        IF APCPV("COMMPX")=""

               SET APCPE("ERROR")="E610"

               QUIT 

 +3        SET APCPV("COMMPX")=$PIECE(^AUPNPAT(AUPNPAT,51,APCPV("COMMPX"),0),U,3)

           IF APCPV("COMMPX")=""

               SET APCPE("ERROR")="E611"

               QUIT 

 +4        IF '$DATA(^AUTTCOM(APCPV("COMMPX"),0))

               SET APCPE("ERROR")="E611"

               QUIT 

 +5        IF APCPV("COMMPX")]""

               SET APCPV("COMM CODE")=$PIECE(^AUTTCOM(APCPV("COMMPX"),0),U,8)

               IF APCPV("COMM CODE")=""

                   SET APCPE("ERROR")="E612"

                   QUIT 

TRIBE     ;

 +1        SET X=$PIECE(^AUPNPAT(AUPNPAT,11),U,8)

           IF X=""

               SET APCPE("ERROR")="E605"

               DO RESET

               QUIT 

 +2        IF $PIECE(^AUTTTRI(X,0),U,4)="Y"

               SET APCPE("ERROR")="E607"

               DO RESET

               QUIT 

 +3        SET APCPV("TRIBE CODE")=$PIECE(^AUTTTRI(X,0),U,2)

           IF APCPV("TRIBE CODE")=""

               SET APCPE("ERROR")="E608"

               QUIT 

CHART      SET (APCPV("T-HASF"),APCPV("CHART"))=""

 +1        IF $DATA(^AUPNPAT(APCPV("PATIENT DFN"),41,APCPV("LOC DFN"),0))#2

               SET APCPV("T-HASF")=$PIECE(^(0),U)

               SET APCPV("CHART")=$PIECE(^(0),U,2)

 +2        IF APCPV("CHART")=""

               SET APCPV("CHART")=999999

               QUIT 

 +3        SET APCPV("CHART")=$EXTRACT("000000",1,6-$LENGTH(APCPV("CHART")))_APCPV("CHART")

 +4        QUIT 

 +5       ;

RESET     ;EP

 +1        IF $PIECE(APCPV("V REC"),U,11)

               QUIT 

 +2        SET DA=APCP("V DFN")

           SET DIE="^AUPNVSIT("

           SET DR=".13///"_DT

           DO ^DIE

           KILL DA,DIU,DIE,DR,DIV

 +3        QUIT