BHSSUPP ;IHS/CIA/MGH - Health Summary for Supplements ;22-Apr-2014 09:37;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**2,4,9**;March 17, 2006;Build 16
;===================================================================
;Taken from APCHS9A
; IHS/TUCSON/LAB - PART 9 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS RPMS/PCC Health Summary;**9,10**;JUN 24, 1997
;VA version of IHS components for supplemental summaries
;Patch 2 code set versioning
;------------------------------------------------------------
SUPP ;EP - supplements
N BHSPAT,BHSC1,BHSC2,BHSCI,BHSCM,BHSP,BHSPI,BHSNYR,BHSBD,BHSNVN,BHSUPI
S BHSPAT=DFN
D CKP^GMTSUP Q:$D(GMTSQIT)
S BHSFOR=0 F S BHSFOR=$O(GMTSEG(GMTSEGN,90471,BHSFOR)) Q:BHSFOR'=+BHSFOR!($D(GMTSQIT)) D Q:$D(GMTSQIT)
.S BHSUPI=$G(GMTSEG(GMTSEGN,90471,BHSFOR))
.Q:BHSUPI=""
.Q:'$D(^BHS(90471,BHSUPI))
.Q:$G(^BHS(90471,BHSUPI,1))=""
.D SUPPCHK
.Q:'BHSFOK
.X ^BHS(90471,BHSUPI,1)
EOJ ;
K BHSFOK,BHSFOR,BHSUPI,BHSCNT
Q
SUPPCHK ; <SCREEN>
I '$O(^BHS(90471,BHSUPI,3,0)) S BHSFOK=1 Q
S BHSFOK=0
;Q:'$O(^AUPNPROB("AC",BHSPAT,0))
F BHSPI=0:0 S BHSPI=$O(^AUPNPROB("AC",BHSPAT,BHSPI)) Q:'BHSPI D SUPPCP Q:BHSFOK
Q:BHSFOK
PVCH ;IHS/CMI/LAB - now check for dx in past year per Bill and Charlton by pcp
N X,Y,V,D,E,%
K APCHY,APCHV,^TMP($J,"ALL VISITS")
S BHSNVN=$S($P($G(^APCHSITE(DUZ(2),11,BHSUPI,0)),U,2):$P($G(^APCHSITE(DUZ(2),11,BHSUPI,0)),U,2),1:1)
S BHSNYR=$S($P($G(^APCHSITE(DUZ(2),11,BHSUPI,0)),U,3):$P($G(^APCHSITE(DUZ(2),11,BHSUPI,0)),U,3),1:1)
S BHSNYR=BHSNYR*365
S BHSBD=$$FMADD^XLFDT(DT,-(BHSNYR))
S APCHY="^TMP($J,""ALL VISITS"",",%=BHSPAT_"^ALL VISITS;DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(DT,-365))_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,APCHY)
I '$D(^TMP($J,"ALL VISITS",1)) Q
S (X,BHSCNT,BHSFOK)=0 F S X=$O(^TMP($J,"ALL VISITS",X)) Q:X'=+X!(BHSFOK) 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))
.;S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) D S BHSCM=$P($G(^AUPNVPOV(Y,0)),U) I BHSCM S BHSCM=$P($G(^ICD9(BHSCM,0)),U) I BHSCM]"" D CHKCODE
.;code set versioning
.N BHSVDT
.S BHSVDT=$P(+V,".")
.;Patch 9 for ICD-10
.I $$AICD^BHSUTL D
..S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) S BHSCM=$P($G(^AUPNVPOV(Y,0)),U) I BHSCM S BHSCM=$P($$ICDDX^ICDEX(BHSCM,BHSVDT,"","I"),U,2) I BHSCM]"" D CHKCODE
.E D
..S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) S BHSCM=$P($G(^AUPNVPOV(Y,0)),U) I BHSCM S BHSCM=$P($$ICDDX^ICDCODE(BHSCM,BHSVDT),U,2) I BHSCM]"" D CHKCODE
.Q:'D
.;S Y=$$PRIMPROV^APCLV(V,"F")
.;Q:'Y
.;I $P(^DIC(7,Y,9999999),U,1)=39 S BHSFOK=1 Q
.;Q:$P($G(^DIC(7,Y,9999999)),U,3)'="Y"
.S BHSCNT=BHSCNT+1
.I BHSCNT'<BHSNVN S BHSFOK=1
.;S BHSFOK=1
.Q
K ^TMP($J,"ALL VISITS"),APCHV,APCHY
Q
CHKCODE ;
S D=0
F BHSCI=0:0 S BHSCI=$O(^BHS(90471,BHSUPI,3,BHSCI)) Q:'BHSCI D CHKCODE1 Q:D
Q
CHKCODE1 ;
S D=0
S BHSC1=$P(^BHS(90471,BHSUPI,3,BHSCI,0),U,1)
I BHSC1["-" S BHSC2=$P(BHSC1,"-",2),BHSC1=$P(BHSC1,"-",1)
E S BHSC2=BHSC1
S BHSC1=BHSC1_" ",BHSC2=BHSC2_" "
I BHSC1'](BHSCM_" "),(BHSCM_" ")']BHSC2 S D=1
Q
SUPPCP ;
S BHSP=^AUPNPROB(BHSPI,0) Q:$P(BHSP,U,12)'="A"
;S BHSCM=$P(^ICD9(+$P(BHSP,U),0),U)
;code set versioning
;Patch 9 added for ICD-10
I $$AICD^BHSUTL S BHSCM=$P($$ICDDX^ICDEX(+$P(BHSP,U),"","","I"),U,2)
E S BHSCM=$P($$ICDDX^ICDCODE(+$P(BHSP,U)),U,2)
F BHSCI=0:0 S BHSCI=$O(^BHS(90471,BHSUPI,3,BHSCI)) Q:'BHSCI D SUPPCR Q:BHSFOK
Q
SUPPCR S BHSC1=$P(^BHS(90471,BHSUPI,3,BHSCI,0),U)
I BHSC1["-" S BHSC2=$P(BHSC1,"-",2),BHSC1=$P(BHSC1,"-",1)
E S BHSC2=BHSC1
S BHSC1=BHSC1_" ",BHSC2=BHSC2_" "
I BHSC1'](BHSCM_" "),(BHSCM_" ")']BHSC2 S BHSFOK=1
Q
BHSSUPP ;IHS/CIA/MGH - Health Summary for Supplements ;22-Apr-2014 09:37;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**2,4,9**;March 17, 2006;Build 16
+2 ;===================================================================
+3 ;Taken from APCHS9A
+4 ; IHS/TUCSON/LAB - PART 9 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+5 ;;2.0;IHS RPMS/PCC Health Summary;**9,10**;JUN 24, 1997
+6 ;VA version of IHS components for supplemental summaries
+7 ;Patch 2 code set versioning
+8 ;------------------------------------------------------------
SUPP ;EP - supplements
+1 NEW BHSPAT,BHSC1,BHSC2,BHSCI,BHSCM,BHSP,BHSPI,BHSNYR,BHSBD,BHSNVN,BHSUPI
+2 SET BHSPAT=DFN
+3 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+4 SET BHSFOR=0
FOR
SET BHSFOR=$ORDER(GMTSEG(GMTSEGN,90471,BHSFOR))
IF BHSFOR'=+BHSFOR!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+5 SET BHSUPI=$GET(GMTSEG(GMTSEGN,90471,BHSFOR))
+6 IF BHSUPI=""
QUIT
+7 IF '$DATA(^BHS(90471,BHSUPI))
QUIT
+8 IF $GET(^BHS(90471,BHSUPI,1))=""
QUIT
+9 DO SUPPCHK
+10 IF 'BHSFOK
QUIT
+11 XECUTE ^BHS(90471,BHSUPI,1)
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
EOJ ;
+1 KILL BHSFOK,BHSFOR,BHSUPI,BHSCNT
+2 QUIT
SUPPCHK ; <SCREEN>
+1 IF '$ORDER(^BHS(90471,BHSUPI,3,0))
SET BHSFOK=1
QUIT
+2 SET BHSFOK=0
+3 ;Q:'$O(^AUPNPROB("AC",BHSPAT,0))
+4 FOR BHSPI=0:0
SET BHSPI=$ORDER(^AUPNPROB("AC",BHSPAT,BHSPI))
IF 'BHSPI
QUIT
DO SUPPCP
IF BHSFOK
QUIT
+5 IF BHSFOK
QUIT
PVCH ;IHS/CMI/LAB - now check for dx in past year per Bill and Charlton by pcp
+1 NEW X,Y,V,D,E,%
+2 KILL APCHY,APCHV,^TMP($JOB,"ALL VISITS")
+3 SET BHSNVN=$SELECT($PIECE($GET(^APCHSITE(DUZ(2),11,BHSUPI,0)),U,2):$PIECE($GET(^APCHSITE(DUZ(2),11,BHSUPI,0)),U,2),1:1)
+4 SET BHSNYR=$SELECT($PIECE($GET(^APCHSITE(DUZ(2),11,BHSUPI,0)),U,3):$PIECE($GET(^APCHSITE(DUZ(2),11,BHSUPI,0)),U,3),1:1)
+5 SET BHSNYR=BHSNYR*365
+6 SET BHSBD=$$FMADD^XLFDT(DT,-(BHSNYR))
+7 SET APCHY="^TMP($J,""ALL VISITS"","
SET %=BHSPAT_"^ALL VISITS;DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(DT,-365))_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,APCHY)
+8 IF '$DATA(^TMP($JOB,"ALL VISITS",1))
QUIT
+9 SET (X,BHSCNT,BHSFOK)=0
FOR
SET X=$ORDER(^TMP($JOB,"ALL VISITS",X))
IF X'=+X!(BHSFOK)
QUIT
SET V=$PIECE(^TMP($JOB,"ALL VISITS",X),U,5)
Begin DoDot:1
+10 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+11 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+12 IF "DAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+13 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+14 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+15 ;S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) D S BHSCM=$P($G(^AUPNVPOV(Y,0)),U) I BHSCM S BHSCM=$P($G(^ICD9(BHSCM,0)),U) I BHSCM]"" D CHKCODE
+16 ;code set versioning
+17 NEW BHSVDT
+18 SET BHSVDT=$PIECE(+V,".")
+19 ;Patch 9 for ICD-10
+20 IF $$AICD^BHSUTL
Begin DoDot:2
+21 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
SET BHSCM=$PIECE($GET(^AUPNVPOV(Y,0)),U)
IF BHSCM
SET BHSCM=$PIECE($$ICDDX^ICDEX(BHSCM,BHSVDT,"","I"),U,2)
IF BHSCM]""
DO CHKCODE
End DoDot:2
+22 IF '$TEST
Begin DoDot:2
+23 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
SET BHSCM=$PIECE($GET(^AUPNVPOV(Y,0)),U)
IF BHSCM
SET BHSCM=$PIECE($$ICDDX^ICDCODE(BHSCM,BHSVDT),U,2)
IF BHSCM]""
DO CHKCODE
End DoDot:2
+24 IF 'D
QUIT
+25 ;S Y=$$PRIMPROV^APCLV(V,"F")
+26 ;Q:'Y
+27 ;I $P(^DIC(7,Y,9999999),U,1)=39 S BHSFOK=1 Q
+28 ;Q:$P($G(^DIC(7,Y,9999999)),U,3)'="Y"
+29 SET BHSCNT=BHSCNT+1
+30 IF BHSCNT'<BHSNVN
SET BHSFOK=1
+31 ;S BHSFOK=1
+32 QUIT
End DoDot:1
+33 KILL ^TMP($JOB,"ALL VISITS"),APCHV,APCHY
+34 QUIT
CHKCODE ;
+1 SET D=0
+2 FOR BHSCI=0:0
SET BHSCI=$ORDER(^BHS(90471,BHSUPI,3,BHSCI))
IF 'BHSCI
QUIT
DO CHKCODE1
IF D
QUIT
+3 QUIT
CHKCODE1 ;
+1 SET D=0
+2 SET BHSC1=$PIECE(^BHS(90471,BHSUPI,3,BHSCI,0),U,1)
+3 IF BHSC1["-"
SET BHSC2=$PIECE(BHSC1,"-",2)
SET BHSC1=$PIECE(BHSC1,"-",1)
+4 IF '$TEST
SET BHSC2=BHSC1
+5 SET BHSC1=BHSC1_" "
SET BHSC2=BHSC2_" "
+6 IF BHSC1'](BHSCM_" ")
IF (BHSCM_" ")']BHSC2
SET D=1
+7 QUIT
SUPPCP ;
+1 SET BHSP=^AUPNPROB(BHSPI,0)
IF $PIECE(BHSP,U,12)'="A"
QUIT
+2 ;S BHSCM=$P(^ICD9(+$P(BHSP,U),0),U)
+3 ;code set versioning
+4 ;Patch 9 added for ICD-10
+5 IF $$AICD^BHSUTL
SET BHSCM=$PIECE($$ICDDX^ICDEX(+$PIECE(BHSP,U),"","","I"),U,2)
+6 IF '$TEST
SET BHSCM=$PIECE($$ICDDX^ICDCODE(+$PIECE(BHSP,U)),U,2)
+7 FOR BHSCI=0:0
SET BHSCI=$ORDER(^BHS(90471,BHSUPI,3,BHSCI))
IF 'BHSCI
QUIT
DO SUPPCR
IF BHSFOK
QUIT
+8 QUIT
SUPPCR SET BHSC1=$PIECE(^BHS(90471,BHSUPI,3,BHSCI,0),U)
+1 IF BHSC1["-"
SET BHSC2=$PIECE(BHSC1,"-",2)
SET BHSC1=$PIECE(BHSC1,"-",1)
+2 IF '$TEST
SET BHSC2=BHSC1
+3 SET BHSC1=BHSC1_" "
SET BHSC2=BHSC2_" "
+4 IF BHSC1'](BHSCM_" ")
IF (BHSCM_" ")']BHSC2
SET BHSFOK=1
+5 QUIT
