Routine: APCPACHA

APCPACHA ; IHS/TUCSON/LAB - create CHA activity reporting system record AUGUST 14, 1992 ; [ 09/16/02 12:15 PM ]

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

 D ACTCODE

 S (APCPCHD1,APCPCHD2)="   "

 D POV

 G:$D(APCPE) EOJ

 D TIME

 G:$D(APCPE) EOJ

 D CHART

 D SETTX

EOJ ;

 K APCPT,APCPCHD1,APCPCHD2

ACTCODE ;

 I APCPV("SRV CAT")="N" S APCPT("ACTC")="03" Q

 S APCPT("ACTC")=$S(APCPV("CLINIC CODE")=11:"01",1:"02")

POV ;get POV information

 S (APCPT(1),APCPT(2))=0 F  S APCPT(2)=$O(^AUPNVPOV("AD",APCP("V DFN"),APCPT(2))) Q:APCPT(1)>1!(APCPT(2)'=+APCPT(2))!($D(APCPE("ERROR")))  S APCPT(1)=APCPT(1)+1 D GETPOV

GETPOV ;

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

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

GETCODE ;

 S APCPT("ICD")=$P(APCPT("ICD"),".")_$P(APCPT("ICD"),".",2)_" "

 I $E(APCPT("X"))="V" S APCPT("X")=(9_$E(APCPT("X"),2,9999)-.000001),APCPT("X")="V"_$E(APCPT("X"),2,9999),APCPT("X")=$P(APCPT("X"),".")_$P(APCPT("X"),".",2)_" " G HIGH

 I $E(APCPT("X"))="0" S APCPT("X")=(9_$E(APCPT("X"),2,9999)-.000001),APCPT("X")="0"_$E(APCPT("X"),2,9999),APCPT("X")=$P(APCPT("X"),".")_$P(APCPT("X"),".",2)_" " G HIGH

 I $E(APCPT("X"))="." S APCPT("X")=(9_$E(APCPT("X"),2,9999)-.000001),APCPT("X")="."_$E(APCPT("X"),2,9999),APCPT("X")=$P(APCPT("X"),".")_$P(APCPT("X"),".",2)_" " G HIGH

 S APCPT("X")=APCPT("X")-.000001

 S APCPT("AC")="",APCPT("X")=($P(APCPT("X"),".")_$P(APCPT("X"),".",2))_" "

HIGH S APCPT("HIGH")=$O(^AUTTCHA("AH",APCPT("X"))) I APCPT("HIGH")="" S APCPE("ERROR")="E064",APCPE("EDFN")=APCPT(2),APCPE("FILE")=9000010.07 Q

 S APCPT("DA1")=$O(^AUTTCHA("AH",APCPT("HIGH"),"")) I APCPT("DA1")="" S APCPE("ERROR")="E064",APCPE("EDFN")=APCPT(2),APCPE("FILE")=9000010.07 Q

 S APCPT("DA2")=$O(^AUTTCHA("AH",APCPT("HIGH"),APCPT("DA1"),""))

 S APCPT("LOW")=$P(^AUTTCHA(APCPT("DA1"),11,APCPT("DA2"),0),U)_" "

 I APCPT("LOW")]APCPT("ICD") S APCPE("ERROR")="E064",APCPE("FILE")=9000010.07,APCPE("EDFN")=APCPT(2) Q

 S APCPT("AC")=$P(^AUTTCHA(APCPT("DA1"),0),U)

SETPOV S APCPT("VAR")="APCPCHD"_APCPT(1),@APCPT("VAR")=APCPT("AC")

TIME ;

 S APCPT("AT REC")=$O(^AUPNVTM("AD",APCP("V DFN"),""))

 I APCPT("AT REC")="" S APCPE("ERROR")="E054" Q

 S APCPT("ACT TIME MIN")=$P(^AUPNVTM(APCPT("AT REC"),0),U),APCPT("TRAVEL TIME MIN")=$P(^AUPNVTM(APCPT("AT REC"),0),U,4)

 I 'APCPT("ACT TIME MIN") S APCPE("ERROR")="E052" Q

 S APCPT("ACT TIME MIN")=APCPT("ACT TIME MIN")*APCPT("CHA")

 S X=APCPT("ACT TIME MIN") D CONVERT S:H>9 H=9

 S APCPT("ACT TIME")=H_M

 I 'APCPT("TRAVEL TIME MIN") S APCPT("TRAVEL TIME MIN")=0 S APCPT("TRAVEL TIME")="000" Q

 S X=APCPT("TRAVEL TIME MIN") D CONVERT I H>9 S APCPE("ERROR")="E053" Q

 S APCPT("TRAVEL TIME")=H_M

 K X,Y,M,H

CHART ;CHANGE CHART TO DUZ(2) IF EQUAL 999999

 S APCPT("CHA CHART")=""

 I $D(^AUPNPAT(APCPV("PATIENT DFN"),41,DUZ(2),0))#2 S APCPT("CHA CHART")=$P(^AUPNPAT(APCPV("PATIENT DFN"),41,DUZ(2),0),U,2)

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

 I APCPT("CHA CHART")="" S APCPT("CHA CHART")=999999

SETTX ;

 S APCPT("VD")=$E(APCPV("V DATE"),4,5)_$E(APCPV("V DATE"),6,7)_$E(APCPV("V DATE"),2,3)

 S APCP("CHA")=APCP("CHA")+1,APCP("COUNT")=APCP("COUNT")+1

 S APCPV("CHA TX GENERATED")=1,APCPV("TX GENERATED")=1

 S APCPV("TX")="CHN"_U_14_U_$E(APCP("RUN LOCATION"),1,2)_U_$E(APCP("RUN LOCATION"),3,4)_U_$E(APCP("RUN LOCATION"),5,6)_U_"00"_U_APCPT("VD")_U_$E(APCPV("COMM CODE"),5,7)_U_APCPT("ACTC")_U_APCPCHD1_U_U_U_APCPCHD2_U_U_U

 S APCPV("TX")=APCPV("TX")_APCPT("ACT TIME")_U_U_APCPT("CHA CHART")_U_$E(AUPNDOB,4,5)_$E(AUPNDOB,6,7)_$E(AUPNDOB,2,3)_U_AUPNSEX_U_U_APCPT("TRAVEL TIME")

 S ^BAPCDATA(APCP("COUNT"))=APCPV("TX")

CONVERT ;convert minutes to hours

 S H=$P((X/60),"."),M=X-(H*60)

 I $L(M)=1 S M=0_M

 S:'H H=0

 ;left zero fill minutes

 ;if hours >9 error

APCPACHA  ; IHS/TUCSON/LAB - create CHA activity reporting system record AUGUST 14, 1992 ; [ 09/16/02 12:15 PM ]

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

 +2       ;

 +3        DO ACTCODE

 +4        SET (APCPCHD1,APCPCHD2)="   "

 +5        DO POV

 +6        IF $DATA(APCPE)

               GOTO EOJ

 +7        DO TIME

 +8        IF $DATA(APCPE)

               GOTO EOJ

 +9        DO CHART

 +10       DO SETTX

EOJ       ;

 +1        KILL APCPT,APCPCHD1,APCPCHD2

 +2        QUIT

ACTCODE   ;

 +1        IF APCPV("SRV CAT")="N"

               SET APCPT("ACTC")="03"

               QUIT

 +2        SET APCPT("ACTC")=$SELECT(APCPV("CLINIC CODE")=11:"01",1:"02")

 +3        QUIT

POV       ;get POV information

 +1        SET (APCPT(1),APCPT(2))=0

FOR

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

               IF APCPT(1)>1!(APCPT(2)'=+APCPT(2))!($DATA(APCPE("ERROR")))

                   QUIT

               SET APCPT(1)=APCPT(1)+1

               DO GETPOV

 +2        QUIT

GETPOV    ;

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

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

           DO ^APCPCICD

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

               QUIT

GETCODE   ;

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

 +2        IF $EXTRACT(APCPT("X"))="V"

               SET APCPT("X")=(9_$EXTRACT(APCPT("X"),2,9999)-.000001)

               SET APCPT("X")="V"_$EXTRACT(APCPT("X"),2,9999)

               SET APCPT("X")=$PIECE(APCPT("X"),".")_$PIECE(APCPT("X"),".",2)_" "

               GOTO HIGH

 +3        IF $EXTRACT(APCPT("X"))="0"

               SET APCPT("X")=(9_$EXTRACT(APCPT("X"),2,9999)-.000001)

               SET APCPT("X")="0"_$EXTRACT(APCPT("X"),2,9999)

               SET APCPT("X")=$PIECE(APCPT("X"),".")_$PIECE(APCPT("X"),".",2)_" "

               GOTO HIGH

 +4        IF $EXTRACT(APCPT("X"))="."

               SET APCPT("X")=(9_$EXTRACT(APCPT("X"),2,9999)-.000001)

               SET APCPT("X")="."_$EXTRACT(APCPT("X"),2,9999)

               SET APCPT("X")=$PIECE(APCPT("X"),".")_$PIECE(APCPT("X"),".",2)_" "

               GOTO HIGH

 +5        SET APCPT("X")=APCPT("X")-.000001

 +6        SET APCPT("AC")=""

           SET APCPT("X")=($PIECE(APCPT("X"),".")_$PIECE(APCPT("X"),".",2))_" "

HIGH       SET APCPT("HIGH")=$ORDER(^AUTTCHA("AH",APCPT("X")))

           IF APCPT("HIGH")=""

               SET APCPE("ERROR")="E064"

               SET APCPE("EDFN")=APCPT(2)

               SET APCPE("FILE")=9000010.07

               QUIT

 +1        SET APCPT("DA1")=$ORDER(^AUTTCHA("AH",APCPT("HIGH"),""))

           IF APCPT("DA1")=""

               SET APCPE("ERROR")="E064"

               SET APCPE("EDFN")=APCPT(2)

               SET APCPE("FILE")=9000010.07

               QUIT

 +2        SET APCPT("DA2")=$ORDER(^AUTTCHA("AH",APCPT("HIGH"),APCPT("DA1"),""))

 +3        SET APCPT("LOW")=$PIECE(^AUTTCHA(APCPT("DA1"),11,APCPT("DA2"),0),U)_" "

 +4        IF APCPT("LOW")]APCPT("ICD")

               SET APCPE("ERROR")="E064"

               SET APCPE("FILE")=9000010.07

               SET APCPE("EDFN")=APCPT(2)

               QUIT

 +5        SET APCPT("AC")=$PIECE(^AUTTCHA(APCPT("DA1"),0),U)

SETPOV     SET APCPT("VAR")="APCPCHD"_APCPT(1)

           SET @APCPT("VAR")=APCPT("AC")

 +1        QUIT

 +2       ;

TIME      ;

 +1        SET APCPT("AT REC")=$ORDER(^AUPNVTM("AD",APCP("V DFN"),""))

 +2        IF APCPT("AT REC")=""

               SET APCPE("ERROR")="E054"

               QUIT

 +3        SET APCPT("ACT TIME MIN")=$PIECE(^AUPNVTM(APCPT("AT REC"),0),U)

           SET APCPT("TRAVEL TIME MIN")=$PIECE(^AUPNVTM(APCPT("AT REC"),0),U,4)

 +4        IF 'APCPT("ACT TIME MIN")

               SET APCPE("ERROR")="E052"

               QUIT

 +5        SET APCPT("ACT TIME MIN")=APCPT("ACT TIME MIN")*APCPT("CHA")

 +6        SET X=APCPT("ACT TIME MIN")

           DO CONVERT

           IF H>9

               SET H=9

 +7        SET APCPT("ACT TIME")=H_M

 +8        IF 'APCPT("TRAVEL TIME MIN")

               SET APCPT("TRAVEL TIME MIN")=0

               SET APCPT("TRAVEL TIME")="000"

               QUIT

 +9        SET X=APCPT("TRAVEL TIME MIN")

           DO CONVERT

           IF H>9

               SET APCPE("ERROR")="E053"

               QUIT

 +10       SET APCPT("TRAVEL TIME")=H_M

 +11       KILL X,Y,M,H

 +12       QUIT

CHART     ;CHANGE CHART TO DUZ(2) IF EQUAL 999999

 +1        SET APCPT("CHA CHART")=""

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

               SET APCPT("CHA CHART")=$PIECE(^AUPNPAT(APCPV("PATIENT DFN"),41,DUZ(2),0),U,2)

 +3        IF APCPT("CHA CHART")=""

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

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

 +4        IF APCPT("CHA CHART")=""

               SET APCPT("CHA CHART")=999999

 +5        QUIT

SETTX     ;

 +1        SET APCPT("VD")=$EXTRACT(APCPV("V DATE"),4,5)_$EXTRACT(APCPV("V DATE"),6,7)_$EXTRACT(APCPV("V DATE"),2,3)

 +2        SET APCP("CHA")=APCP("CHA")+1

           SET APCP("COUNT")=APCP("COUNT")+1

 +3        SET APCPV("CHA TX GENERATED")=1

           SET APCPV("TX GENERATED")=1

 +4        SET APCPV("TX")="CHN"_U_14_U_$EXTRACT(APCP("RUN LOCATION"),1,2)_U_$EXTRACT(APCP("RUN LOCATION"),3,4)_U_$EXTRACT(APCP("RUN LOCATION"),5,6)_U_"00"_U_APCPT("VD")_U_$EXTRACT(APCPV("COMM CODE"),5,7)_U_APCPT("ACTC")_U_APCPCHD1_U_U_U_APCPCHD2_U_U_U

 +5        SET APCPV("TX")=APCPV("TX")_APCPT("ACT TIME")_U_U_APCPT("CHA CHART")_U_$EXTRACT(AUPNDOB,4,5)_$EXTRACT(AUPNDOB,6,7)_$EXTRACT(AUPNDOB,2,3)_U_AUPNSEX_U_U_APCPT("TRAVEL TIME")

 +6        SET ^BAPCDATA(APCP("COUNT"))=APCPV("TX")

 +7        QUIT

 +8       ;

CONVERT   ;convert minutes to hours

 +1        SET H=$PIECE((X/60),".")

           SET M=X-(H*60)

 +2        IF $LENGTH(M)=1

               SET M=0_M

 +3        IF 'H

               SET H=0

 +4        QUIT

 +5       ;left zero fill minutes

 +6       ;if hours >9 error

APCPACHA.m