APCPHPOV.m

APCPHPOV ; IHS/TUCSON/LAB - GET POV INFO FOR INPATIENT RECORD AUGUST 14, 1992 ; [ 02/14/00 2:23 PM ]

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

 ;IHS/CMI/LAB - patch 4 # of dxs increased to 9

 ;

 K APCPE("ERROR")

START ;

 S (APCPH("AAC"),APCPH("AAP"),APCPH("INJ"),APCPHDX1,APCPHDX2,APCPHDX3,APCPHDX4,APCPHDX5,APCPHDX6,APCPHHA1,APCPHHA2,APCPHHA3,APCPHHA4,APCPHHA5,APCPHHA6)=""

 S (C,O)=0 F  S O=$O(^AUPNVPOV("AD",APCP("V DFN"),O)) Q:C>0!(O'=+O)!($D(APCPE("ERROR")))  I $P(^AUPNVPOV(O,0),U,12)="P" S C=C+1 D GETPOV

 I $D(APCPE("ERROR")) Q

 S O=0 F  S O=$O(^AUPNVPOV("AD",APCP("V DFN"),O)) Q:O'=+O!($D(APCPE("ERROR")))!(C>8)  I $P(^AUPNVPOV(O,0),U,12)'="P" S C=C+1 D GETPOV ;IHS/CMI/LAB - fix # of povs per Cheryl Chase

EOJ ;

 K APCPT,X,Y,I,M,N,O,C

 Q

 ;

GETPOV ;

 S APCPT("ICD PTR")=$P(^AUPNVPOV(O,0),U),APCPT("ICD")=$P(^ICD9(APCPT("ICD PTR"),0),U) D ^APCPCICD

 Q:$D(APCPE("ERROR"))

 I $D(APCPT("AGEE")),APCPV("SRV CAT")="H",'$D(^APCDINPT(9,11,"AC",APCPT("ICD"))) S APCPE("ERROR")="E046" Q

 I $D(APCPT("AGEE")),'$D(APCPV("ACC")) S APCPE("ERROR")="E048" Q

 S APCPH("POV",C)=APCPT("ICD")

 I $P(APCPT("ICD"),".")>799,APCPH("INJ")="" D RIJ

 I $P(APCPT("ICD"),".")>799,APCPH("AAP")="" S X=$P(^AUPNVPOV(O,0),U,11) I X]"" S APCPH("AAP")=$S(X="A":"01",X="B":"02",X="C":"03",X="D":"04",X="E":"05",X="F":"06",X="G":"07",X="H":"08",X="I":"09",X="J":"10",X="K":"11",X="L":"12",1:"  ")

 S APCPH("HOSP AQ")=$P(^AUPNVPOV(O,0),U,7) I APCPH("HOSP AQ")'=1 S APCPH("HOSP AQ")=""

 S APCPT("ICD")=$P(APCPT("ICD"),".")_$P(APCPT("ICD"),".",2),N=$L(APCPT("ICD"))+1 F M=N:1:5 S APCPT("ICD")=APCPT("ICD")_" "

SETPOV S APCPH("VAR")="APCPHDX"_C S @APCPH("VAR")=APCPT("ICD")

 S APCPH("VAR")="APCPHHA"_C S @APCPH("VAR")=APCPH("HOSP AQ")

 Q

RIJ ;

 S APCPH("INJP")=$P(^AUPNVPOV(O,0),U,9) Q:APCPH("INJP")=""

 S APCPH("HOLD")=APCPT("ICD"),APCPT("ICD")=$P(^ICD9(APCPH("INJP"),0),U)

 I $E(APCPT("ICD"))'="E" S APCPE("ERROR")="E005" Q

 S APCPT("ICD")=$E(APCPT("ICD"),2,99)

 D ^APCPCICD

 S APCPH("INJ")=APCPT("ICD"),APCPT("ICD")=APCPH("HOLD") K APCPH("HOLD")

 Q:$D(APCPE("ERROR"))

 S APCPH("INJ")=$P(APCPH("INJ"),".")_$P(APCPH("INJ"),".",2),N=$L(APCPH("INJ"))+1 F M=N:1:4 S APCPH("INJ")=APCPH("INJ")_" "

 ;

 Q

APCPHPOV  ; IHS/TUCSON/LAB - GET POV INFO FOR INPATIENT RECORD AUGUST 14, 1992 ; [ 02/14/00 2:23 PM ]

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

 +2       ;IHS/CMI/LAB - patch 4 # of dxs increased to 9

 +3       ;

 +4        KILL APCPE("ERROR")

START     ;

 +1        SET (APCPH("AAC"),APCPH("AAP"),APCPH("INJ"),APCPHDX1,APCPHDX2,APCPHDX3,APCPHDX4,APCPHDX5,APCPHDX6,APCPHHA1,APCPHHA2,APCPHHA3,APCPHHA4,APCPHHA5,APCPHHA6)=""

 +2        SET (C,O)=0

           FOR 

               SET O=$ORDER(^AUPNVPOV("AD",APCP("V DFN"),O))

               IF C>0!(O'=+O)!($DATA(APCPE("ERROR")))

                   QUIT 

               IF $PIECE(^AUPNVPOV(O,0),U,12)="P"

                   SET C=C+1

                   DO GETPOV

 +3        IF $DATA(APCPE("ERROR"))

               QUIT 

 +4       ;IHS/CMI/LAB - fix # of povs per Cheryl Chase

           SET O=0

           FOR 

               SET O=$ORDER(^AUPNVPOV("AD",APCP("V DFN"),O))

               IF O'=+O!($DATA(APCPE("ERROR")))!(C>8)

                   QUIT 

               IF $PIECE(^AUPNVPOV(O,0),U,12)'="P"

                   SET C=C+1

                   DO GETPOV

EOJ       ;

 +1        KILL APCPT,X,Y,I,M,N,O,C

 +2        QUIT 

 +3       ;

GETPOV    ;

 +1        SET APCPT("ICD PTR")=$PIECE(^AUPNVPOV(O,0),U)

           SET APCPT("ICD")=$PIECE(^ICD9(APCPT("ICD PTR"),0),U)

           DO ^APCPCICD

 +2        IF $DATA(APCPE("ERROR"))

               QUIT 

 +3        IF $DATA(APCPT("AGEE"))

               IF APCPV("SRV CAT")="H"

                   IF '$DATA(^APCDINPT(9,11,"AC",APCPT("ICD")))

                       SET APCPE("ERROR")="E046"

                       QUIT 

 +4        IF $DATA(APCPT("AGEE"))

               IF '$DATA(APCPV("ACC"))

                   SET APCPE("ERROR")="E048"

                   QUIT 

 +5        SET APCPH("POV",C)=APCPT("ICD")

 +6        IF $PIECE(APCPT("ICD"),".")>799

               IF APCPH("INJ")=""

                   DO RIJ

 +7        IF $PIECE(APCPT("ICD"),".")>799

               IF APCPH("AAP")=""

                   SET X=$PIECE(^AUPNVPOV(O,0),U,11)

                   IF X]""

                       SET APCPH("AAP")=$SELECT(X="A":"01",X="B":"02",X="C":"03",X="D":"04",X="E":"05",X="F":"06",X="G":"07",X="H":"08",X="I":"09",X="J":"10",X="K":"11",X="L":"12",1:"  ")

 +8        SET APCPH("HOSP AQ")=$PIECE(^AUPNVPOV(O,0),U,7)

           IF APCPH("HOSP AQ")'=1

               SET APCPH("HOSP AQ")=""

 +9        SET APCPT("ICD")=$PIECE(APCPT("ICD"),".")_$PIECE(APCPT("ICD"),".",2)

           SET N=$LENGTH(APCPT("ICD"))+1

           FOR M=N:1:5

               SET APCPT("ICD")=APCPT("ICD")_" "

SETPOV     SET APCPH("VAR")="APCPHDX"_C

           SET @APCPH("VAR")=APCPT("ICD")

 +1        SET APCPH("VAR")="APCPHHA"_C

           SET @APCPH("VAR")=APCPH("HOSP AQ")

 +2        QUIT 

RIJ       ;

 +1        SET APCPH("INJP")=$PIECE(^AUPNVPOV(O,0),U,9)

           IF APCPH("INJP")=""

               QUIT 

 +2        SET APCPH("HOLD")=APCPT("ICD")

           SET APCPT("ICD")=$PIECE(^ICD9(APCPH("INJP"),0),U)

 +3        IF $EXTRACT(APCPT("ICD"))'="E"

               SET APCPE("ERROR")="E005"

               QUIT 

 +4        SET APCPT("ICD")=$EXTRACT(APCPT("ICD"),2,99)

 +5        DO ^APCPCICD

 +6        SET APCPH("INJ")=APCPT("ICD")

           SET APCPT("ICD")=APCPH("HOLD")

           KILL APCPH("HOLD")

 +7        IF $DATA(APCPE("ERROR"))

               QUIT 

 +8        SET APCPH("INJ")=$PIECE(APCPH("INJ"),".")_$PIECE(APCPH("INJ"),".",2)

           SET N=$LENGTH(APCPH("INJ"))+1

           FOR M=N:1:4

               SET APCPH("INJ")=APCPH("INJ")_" "

 +9       ;

 +10       QUIT