APCHS9A ; IHS/CMI/LAB - PART 9 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 8/27/2007 code set versioning in PVCH and SUPPCP
;
SUPP ;EP - supplements
S APCHSFO=0 F S APCHSFO=$O(^APCHSCTL(APCHSTYP,12,"B",APCHSFO)) Q:APCHSFO'=+APCHSFO!($D(APCHSQIT)) D Q:$D(APCHSQIT)
.S APCHSFOR=$O(^APCHSCTL(APCHSTYP,12,"B",APCHSFO,0))
.S APCHSUPI=$P(^APCHSCTL(APCHSTYP,12,APCHSFOR,0),U,2)
.Q:APCHSUPI=""
.Q:'$D(^APCHSUP(APCHSUPI))
.Q:$G(^APCHSUP(APCHSUPI,11))=""
.D SUPPCHK
.Q:'APCHSFOK
.X ^APCHSUP(APCHSUPI,11)
EOJ ;
K APCHSFOK,APCHSFOR,APCHSUPI
Q
SUPPCHK ; <SCREEN>
I '$O(^APCHSUP(APCHSUPI,13,0)) S APCHSFOK=1 Q
S APCHSFOK=0
;Q:'$O(^AUPNPROB("AC",APCHSPAT,0))
F APCHSPI=0:0 S APCHSPI=$O(^AUPNPROB("AC",APCHSPAT,APCHSPI)) Q:'APCHSPI D SUPPCP Q:APCHSFOK
Q:APCHSFOK
PVCH ;IHS/CMI/LAB - now check for dx in past year per Bill and Charlton by pcp
K APCHY,APCHV,^TMP($J,"ALL VISITS")
S APCHSNVN=$S($P($G(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,2):$P($G(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,2),1:1)
S APCHSNYR=$S($P($G(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,3):$P($G(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,3),1:1)
S APCHSNYR=APCHSNYR*365
S APCHSBD=$$FMADD^XLFDT(DT,-(APCHSNYR))
S APCHY="^TMP($J,""ALL VISITS"",",%=APCHSPAT_"^ALL VISITS;DURING "_APCHSBD_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,APCHY)
I '$D(^TMP($J,"ALL VISITS",1)) Q
S (X,APCHSCNT,APCHSFOK)=0 F S X=$O(^TMP($J,"ALL VISITS",X)) Q:X'=+X!(APCHSFOK) S V=$P(^TMP($J,"ALL VISITS",X),U,5) D
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:"DAHO"'[$P(^AUPNVSIT(V,0),U,7)
.Q:'$D(^AUPNVPRV("AD",V))
.Q:'$D(^AUPNVPOV("AD",V))
.;cmi/anch/maw 8/27/2007 mods for code set versioning
.;S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) S APCHSCM=$P($G(^AUPNVPOV(Y,0)),U) I APCHSCM S APCHSCM=$P($G(^ICD9(APCHSCM,0)),U) I APCHSCM]"" D CHKCODE
.N APCHSVDT
.S APCHSVDT=$P(+V,".")
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) S APCHSCMX=$P($G(^AUPNVPOV(Y,0)),U) I APCHSCMX S APCHSCM=$P($$ICDDX^ICDEX(APCHSCMX,APCHSVDT),U,2) I APCHSCM]"" D CHKCODE
.Q:'D
.;cmi/anch/maw 8/27/2007 end of mods
.;REMOVED PROVIDER CHECK PER CHRIS LAMER BY EMAIL 09/2008
.;S Y=$$PRIMPROV^APCLV(V,"F")
.;Q:'Y
.;I $P(^DIC(7,Y,9999999),U,1)=39 S APCHSFOK=1 Q
.;Q:$P($G(^DIC(7,Y,9999999)),U,3)'="Y"
.S APCHSCNT=APCHSCNT+1
.I APCHSCNT'<APCHSNVN S APCHSFOK=1
.Q
K ^TMP($J,"ALL VISITS"),APCHV,APCHY
Q
CHKCODE ;
S D=0
F APCHSCI=0:0 S APCHSCI=$O(^APCHSUP(APCHSUPI,13,APCHSCI)) Q:'APCHSCI D CHKCODE1 Q:D
Q
CHKCODE1 ;
S D=0
S APCHSC1=$P(^APCHSUP(APCHSUPI,13,APCHSCI,0),U,1)
I $E(APCHSC1)="[" S D=$$ICD^ATXAPI(APCHSCMX,$O(^ATXAX("B",$E(APCHSC1,2,99),0)),9) Q
I APCHSC1["-" S APCHSC2=$P(APCHSC1,"-",2),APCHSC1=$P(APCHSC1,"-",1)
E S APCHSC2=APCHSC1
S APCHSC1=APCHSC1_" ",APCHSC2=APCHSC2_" "
I APCHSC1'](APCHSCM_" "),(APCHSCM_" ")']APCHSC2 S D=1
Q
SUPPCP ;
S APCHSP=^AUPNPROB(APCHSPI,0) Q:$P(APCHSP,U,12)="D"
S APCHSCM=$P($$ICDDX^ICDEX(+$P(APCHSP,U)),U,2)
S APCHSCII=+$$ICDDX^ICDEX(+$P(APCHSP,U))
F APCHSCI=0:0 S APCHSCI=$O(^APCHSUP(APCHSUPI,13,APCHSCI)) Q:'APCHSCI D SUPPCR Q:APCHSFOK
Q
SUPPCR S APCHSC1=$P(^APCHSUP(APCHSUPI,13,APCHSCI,0),U)
I $E(APCHSC1)="[" S APCHSFOK=$$ICD^ATXAPI(APCHSCII,$O(^ATXAX("B",$E(APCHSC1,2,99),0)),9) Q
I APCHSC1["-" S APCHSC2=$P(APCHSC1,"-",2),APCHSC1=$P(APCHSC1,"-",1)
E S APCHSC2=APCHSC1
S APCHSC1=APCHSC1_" ",APCHSC2=APCHSC2_" "
I APCHSC1'](APCHSCM_" "),(APCHSCM_" ")']APCHSC2 S APCHSFOK=1
Q
APCHS9A ; IHS/CMI/LAB - PART 9 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 8/27/2007 code set versioning in PVCH and SUPPCP
+4 ;
SUPP ;EP - supplements
+1 SET APCHSFO=0
FOR
SET APCHSFO=$ORDER(^APCHSCTL(APCHSTYP,12,"B",APCHSFO))
IF APCHSFO'=+APCHSFO!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+2 SET APCHSFOR=$ORDER(^APCHSCTL(APCHSTYP,12,"B",APCHSFO,0))
+3 SET APCHSUPI=$PIECE(^APCHSCTL(APCHSTYP,12,APCHSFOR,0),U,2)
+4 IF APCHSUPI=""
QUIT
+5 IF '$DATA(^APCHSUP(APCHSUPI))
QUIT
+6 IF $GET(^APCHSUP(APCHSUPI,11))=""
QUIT
+7 DO SUPPCHK
+8 IF 'APCHSFOK
QUIT
+9 XECUTE ^APCHSUP(APCHSUPI,11)
End DoDot:1
IF $DATA(APCHSQIT)
QUIT
EOJ ;
+1 KILL APCHSFOK,APCHSFOR,APCHSUPI
+2 QUIT
SUPPCHK ; <SCREEN>
+1 IF '$ORDER(^APCHSUP(APCHSUPI,13,0))
SET APCHSFOK=1
QUIT
+2 SET APCHSFOK=0
+3 ;Q:'$O(^AUPNPROB("AC",APCHSPAT,0))
+4 FOR APCHSPI=0:0
SET APCHSPI=$ORDER(^AUPNPROB("AC",APCHSPAT,APCHSPI))
IF 'APCHSPI
QUIT
DO SUPPCP
IF APCHSFOK
QUIT
+5 IF APCHSFOK
QUIT
PVCH ;IHS/CMI/LAB - now check for dx in past year per Bill and Charlton by pcp
+1 KILL APCHY,APCHV,^TMP($JOB,"ALL VISITS")
+2 SET APCHSNVN=$SELECT($PIECE($GET(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,2):$PIECE($GET(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,2),1:1)
+3 SET APCHSNYR=$SELECT($PIECE($GET(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,3):$PIECE($GET(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,3),1:1)
+4 SET APCHSNYR=APCHSNYR*365
+5 SET APCHSBD=$$FMADD^XLFDT(DT,-(APCHSNYR))
+6 SET APCHY="^TMP($J,""ALL VISITS"","
SET %=APCHSPAT_"^ALL VISITS;DURING "_APCHSBD_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,APCHY)
+7 IF '$DATA(^TMP($JOB,"ALL VISITS",1))
QUIT
+8 SET (X,APCHSCNT,APCHSFOK)=0
FOR
SET X=$ORDER(^TMP($JOB,"ALL VISITS",X))
IF X'=+X!(APCHSFOK)
QUIT
SET V=$PIECE(^TMP($JOB,"ALL VISITS",X),U,5)
Begin DoDot:1
+9 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+10 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+11 IF "DAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+12 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+13 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+14 ;cmi/anch/maw 8/27/2007 mods for code set versioning
+15 ;S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) S APCHSCM=$P($G(^AUPNVPOV(Y,0)),U) I APCHSCM S APCHSCM=$P($G(^ICD9(APCHSCM,0)),U) I APCHSCM]"" D CHKCODE
+16 NEW APCHSVDT
+17 SET APCHSVDT=$PIECE(+V,".")
+18 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
SET APCHSCMX=$PIECE($GET(^AUPNVPOV(Y,0)),U)
IF APCHSCMX
SET APCHSCM=$PIECE($$ICDDX^ICDEX(APCHSCMX,APCHSVDT),U,2)
IF APCHSCM]""
DO CHKCODE
+19 IF 'D
QUIT
+20 ;cmi/anch/maw 8/27/2007 end of mods
+21 ;REMOVED PROVIDER CHECK PER CHRIS LAMER BY EMAIL 09/2008
+22 ;S Y=$$PRIMPROV^APCLV(V,"F")
+23 ;Q:'Y
+24 ;I $P(^DIC(7,Y,9999999),U,1)=39 S APCHSFOK=1 Q
+25 ;Q:$P($G(^DIC(7,Y,9999999)),U,3)'="Y"
+26 SET APCHSCNT=APCHSCNT+1
+27 IF APCHSCNT'<APCHSNVN
SET APCHSFOK=1
+28 QUIT
End DoDot:1
+29 KILL ^TMP($JOB,"ALL VISITS"),APCHV,APCHY
+30 QUIT
CHKCODE ;
+1 SET D=0
+2 FOR APCHSCI=0:0
SET APCHSCI=$ORDER(^APCHSUP(APCHSUPI,13,APCHSCI))
IF 'APCHSCI
QUIT
DO CHKCODE1
IF D
QUIT
+3 QUIT
CHKCODE1 ;
+1 SET D=0
+2 SET APCHSC1=$PIECE(^APCHSUP(APCHSUPI,13,APCHSCI,0),U,1)
+3 IF $EXTRACT(APCHSC1)="["
SET D=$$ICD^ATXAPI(APCHSCMX,$ORDER(^ATXAX("B",$EXTRACT(APCHSC1,2,99),0)),9)
QUIT
+4 IF APCHSC1["-"
SET APCHSC2=$PIECE(APCHSC1,"-",2)
SET APCHSC1=$PIECE(APCHSC1,"-",1)
+5 IF '$TEST
SET APCHSC2=APCHSC1
+6 SET APCHSC1=APCHSC1_" "
SET APCHSC2=APCHSC2_" "
+7 IF APCHSC1'](APCHSCM_" ")
IF (APCHSCM_" ")']APCHSC2
SET D=1
+8 QUIT
SUPPCP ;
+1 SET APCHSP=^AUPNPROB(APCHSPI,0)
IF $PIECE(APCHSP,U,12)="D"
QUIT
+2 SET APCHSCM=$PIECE($$ICDDX^ICDEX(+$PIECE(APCHSP,U)),U,2)
+3 SET APCHSCII=+$$ICDDX^ICDEX(+$PIECE(APCHSP,U))
+4 FOR APCHSCI=0:0
SET APCHSCI=$ORDER(^APCHSUP(APCHSUPI,13,APCHSCI))
IF 'APCHSCI
QUIT
DO SUPPCR
IF APCHSFOK
QUIT
+5 QUIT
SUPPCR SET APCHSC1=$PIECE(^APCHSUP(APCHSUPI,13,APCHSCI,0),U)
+1 IF $EXTRACT(APCHSC1)="["
SET APCHSFOK=$$ICD^ATXAPI(APCHSCII,$ORDER(^ATXAX("B",$EXTRACT(APCHSC1,2,99),0)),9)
QUIT
+2 IF APCHSC1["-"
SET APCHSC2=$PIECE(APCHSC1,"-",2)
SET APCHSC1=$PIECE(APCHSC1,"-",1)
+3 IF '$TEST
SET APCHSC2=APCHSC1
+4 SET APCHSC1=APCHSC1_" "
SET APCHSC2=APCHSC2_" "
+5 IF APCHSC1'](APCHSCM_" ")
IF (APCHSCM_" ")']APCHSC2
SET APCHSFOK=1
+6 QUIT
