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
Q
ACTCODE ;
I APCPV("SRV CAT")="N" S APCPT("ACTC")="03" Q
S APCPT("ACTC")=$S(APCPV("CLINIC CODE")=11:"01",1:"02")
Q
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
Q
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")
Q
;
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
Q
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
Q
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")
Q
;
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
Q
;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
