Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP0D71

BGP0D71.m

Go to the documentation of this file. 
  1. BGP0D71 ; IHS/CMI/LAB - measure C ;
  1.  ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
  1.  ;
  1. IC1 ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1.  ;denominator 1 is active clinical, 6 and older and overweight
  1.  S (BGPOW,BGPOB,BGPBMI)=""
  1.  K BGPALLED,BGPSN,BGPMN,BGPSPEX
  1.  I 'BGPACTUP S BGPSTOP=1 Q
  1.  S BGPBMI=$$BMI^BGP0D6(DFN,BGPEDATE,BGPAGEE)
  1.  S BGPOW=$$OW^BGP0D6(DFN,BGPBMI,BGPAGEE)
  1.  S BGPOB=$$OB^BGP0D6(DFN,BGPBMI,BGPAGEE)
  1.  S BGPOWOB=BGPOW+BGPOB
  1.  I BGPAGEB>5,BGPOWOB,BGPACTCL S BGPD1=1
  1.  I BGPDMD2 S BGPD2=1
  1.  I BGPAGEB>5,BGPOB,BGPACTCL S BGPD3=1
  1.  I BGPD3,BGPAGEB>5,BGPAGEB<12 S BGPD4=1
  1.  I BGPD3,BGPAGEB>11,BGPAGEB<20 S BGPD5=1
  1.  I BGPD3,BGPAGEB>19,BGPAGEB<40 S BGPD6=1
  1.  I BGPD3,BGPAGEB>39,BGPAGEB<60 S BGPD7=1
  1.  I BGPD3,BGPAGEB>59 S BGPD8=1
  1.  I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8) Q
  1.  S BGPMN=$$MEDNUTRD^BGP0D711(DFN,BGP365,BGPEDATE) I BGPMN]"" S BGPN1=1
  1.  S BGPSN=$$SPECNUTR^BGP0D711(DFN,BGP365,BGPEDATE) I BGPSN]"" S BGPN2=1
  1.  S BGPSPEX=$$SPECEX^BGP0D711(DFN,BGP365,BGPEDATE) I BGPSPEX]"" S BGPN3=1
  1.  S BGPOTH=$$OTHREL^BGP0D711(DFN,BGP365,BGPEDATE) I BGPOTH]"" S BGPN4=1
  1.  S BGPVALUE=$$DATE^BGP0UTL($P(BGPMN,U))_" "_$P(BGPMN,U,2)_$S(BGPMN]"":";",1:"")
  1.  S BGPVALUE=BGPVALUE_$$DATE^BGP0UTL($P(BGPSN,U))_" "_$P(BGPSN,U,2)_$S(BGPSN]"":";",1:"")
  1.  S BGPVALUE=BGPVALUE_$$DATE^BGP0UTL($P(BGPSPEX,U))_" "_$P(BGPSPEX,U,2)_$S(BGPSPEX]"":";",1:"")
  1.  S BGPVALUE=BGPVALUE_$$DATE^BGP0UTL($P(BGPOTH,U))_" "_$P(BGPOTH,U,2)
  1.  S V=$S(BGPD1:"OW;",1:"")_$S(BGPD2:"AD;",1:"")_$S(BGPD3:"OB",1:"")
  1.  S V=V_"|||"_BGPVALUE
  1.  S BGPVALUE=V
  1.  K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPALLED,BGPBMI,BGPOW,BGPOB,BGPOWOB,BGPMN,BGPSN,BGPSPEX
  1.  K ^TMP($J,"A")
  1.  Q
  1. I19 ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=0
  1.  K BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ,BGPTOM,BGPTOBS,BGPTC1,BGPTOBD,BGPQ
  1.  S (BGPTUHF,BGPTUQ,BGPTU,BGPTUC,BGPREM,BGPTOBD,BGPTOBX,BGPTC,BGPTC1,BGPQ)=""
  1.  I 'BGPACTUP S BGPSTOP=1 Q  ;must be at least user pop
  1.  I BGPRTYPE=3,'BGPACTCL S BGPSTOP=1 Q   ;for hedis, must be active clinical
  1.  I BGPRTYPE=7 D NEWSTUFF Q
  1.  S BGPTOBP=$$TOBACCO^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
  1.  S BGPSDX=$$DX^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
  1.  ;S BGP1320=$$DENT^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
  1.  S BGPSCPT=$$CPTSM^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
  1.  ;now get last of these
  1.  ;S D=$P(BGPTOBP,U,3),V="HF "_$P(BGPTOBP,U,1)
  1.  ;I $P(BGPSDX,U,2)>D S D=$P(BGPSDX,U,2),V="DX "_$P(BGPSDX,U,1)
  1.  ;I $P(BGP1320,U,2)>D S D=$P(BGP1320,U,2),V="DENTAL 1320"
  1.  ;I $P(BGPSCPT,U,2)>D S D=$P(BGPSCPT,U,2),V="CPT "_$P(BGPSCPT,U,1)
  1.  ;I V["HF ",$P(BGPTOBP,U,1)["CURRENT"!(BGPTOBP["CESSATION") S BGPD2=1
  1.  ;I V["DX ",(BGPSDX]""&(+BGPSDX'="305.13")&(BGPSDX'="V15.82")) S BGPD2=1
  1.  ;I V["DENTAL " S BGPD2=1
  1.  ;I V["CPT ",$P(BGPSCPT,U)["1034F"!($P(BGPSCPT,U)["1035F") S BGPD2=1
  1.  S %=""
  1.  I BGPSDX]"",$P(BGPSDX,U)="V15.82" S %=1
  1.  I BGPSDX]"",$P(BGPSDX,U)="305.13" S %=1
  1.  S F=$P(BGPTOBP,U,1)
  1.  I $P(BGPTOBP,U,1)["CURRENT"!(BGPSDX]""&(%=""))!(F["CESSATION")!($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="1035F")!($P(BGPSCPT,U)="G0376")!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)=99407) S BGPD2=1
  1.  I $P(BGPSCPT,U)=99406!($P(BGPSCPT,U)="G8455")!($P(BGPSCPT,U)="G8456")!($P(BGPSCPT,U)="G8402")!($P(BGPSCPT,U)="G8453") S BGPD2=1
  1.  ;I $P(BGPTOBP,U,1)["CURRENT"!(BGPSDX]""&(%=""))!(BGPTOBP["CESSATION")!($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="1035F")!($P(BGPSCPT,U)=99406)!($P(BGPSCPT,U)=99407)!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)="G0376") S BGPD2=1
  1.  I 'BGPD2 S BGPSTOP=1 Q  ;last item documented is not a tobacco user
  1.  I BGPD2,BGPACTCL S BGPD1=1
  1.  I BGPD1,BGPAGEB<12 S BGPD3=1
  1.  I BGPD1,BGPAGEB>11,BGPAGEB<18 S BGPD4=1
  1.  I BGPD1,BGPAGEB>17 S BGPD5=1
  1.  I BGPRTYPE=3,'BGPD1 S BGPSTOP=1 Q  ;hedis must be active clinical
  1.  S BGPTC=$$PED^BGP0D711(DFN,BGP365,BGPEDATE)
  1.  ;N1 is got education (incl refusals)
  1.  ;N2 is refusal
  1.  ;N11 is educ and no refusal
  1.  ;N3 is quit
  1.  ;N6 is quit or educ w/o refusals
  1.  I $P(BGPTC,U)]"" S BGPN1=1 I $P(BGPTC,U,2)["ref" S BGPN2=1
  1.  I BGPN1,'BGPN2 S BGPN11=1
  1.  I BGPRTYPE'=3 D
  1.  .S BGPTOB=$$TOBACCO^BGP0D7(DFN,BGP365,BGPEDATE)
  1.  .I BGPTOB'["PREVIOUS" S BGPTOB=""
  1.  .S BGPSDXQ=$$DX^BGP0D7(DFN,BGP365,BGPEDATE)
  1.  .S BGPTQ="" I $P(BGPTOB,U)["PREVIOUS"!(+$P(BGPSDXQ,U)="305.13")!($P(BGPSDXQ,U)="V15.82") S BGPN3=1
  1.  .;I $P(BGPTOB,U)["CURRENT" S BGPN3=0  ;
  1.  I BGPN1!(BGPN3) S BGPN5=1  ;new numerator v8.0 patch 1
  1.  I BGPN11!(BGPN3) S BGPN6=1
  1.  I BGPRTYPE=3 S BGPN4=0,BGPTOM=$$TOMPED(DFN,BGP365,BGPEDATE) I BGPTOM S BGPN4=1
  1. NXT ;
  1.  S BGPVALUE=$S(BGPRTYPE=3:"",BGPD2:"UP",1:"")_$S(BGPD1:";AC",1:"")
  1.  I BGPRTYPE'=7 D
  1.  .S BGPVALUE=BGPVALUE_"|||"_$S($P(BGPTC,U):"COUNSELING: "_$$DATE^BGP0UTL($P(BGPTC,U))_" "_$P(BGPTC,U,2),1:"")
  1.  .I BGPN3,BGPRTYPE'=3 S BGPVALUE=BGPVALUE_";QUIT: "_$P(BGPTOB,U)_" "_$P(BGPTOB,U,2)_$S(+BGPSDXQ="305.13":" DX: 305.13 "_$$DATE^BGP0UTL($P(BGPSDXQ,U,2)),$P(BGPSDXQ,U)="V15.82":" DX: V15.82 "_$$DATE^BGP0UTL($P(BGPSDXQ,U,2)),1:"")
  1.  .I BGPN4,BGPRTYPE=3 S BGPVALUE=BGPVALUE_";TO-M "_$$DATE^BGP0UTL($P(BGPTOM,U))
  1.  K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPQ,BGPALLED,BGPTQ,BGPTC,BGPTC1,BGPTOB,BGPSDX,BGP1320,BGPTOM,BGPTOBS,BGPTUHF,BGPTU,BGPTUC,BGPTUQ,BGPTOBD
  1.  Q
  1. DNKA(V) ;EP - is this a DNKA visit?
  1.  NEW D,N
  1.  S D=$$PRIMPOV^APCLV(V,"C")
  1.  I D=".0860" Q 1
  1.  S N=$$PRIMPOV^APCLV(V,"N")
  1.  I $E(D)="V",N["DNKA" Q 1
  1.  I $E(D)="V",N["DID NOT KEEP APPOINTMENT" Q 1
  1.  I $E(D)="V",N["DID NOT KEEP APPT" Q 1
  1.  Q 0
  1. TOMPED(P,BDATE,EDATE) ;EP
  1.  K BGPALLED
  1.  S BGPLPED=""
  1.  S Y="BGPALLED("
  1.  S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BGPALLED(1)) S %="" D  I %]"" S BGPLPED=%
  1.  .S (X,D)=0,T="" F  S X=$O(BGPALLED(X)) Q:X'=+X  D
  1.  ..S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
  1.  ..Q:'T
  1.  ..Q:'$D(^AUTTEDT(T,0))
  1.  ..S T=$P(^AUTTEDT(T,0),U,2)
  1.  ..I T'="TO-M" Q
  1.  ..I $P(BGPLPED,U)<$P(BGPALLED(X),U) S %=$P(BGPALLED(X),U)_U_T
  1.  I BGPLPED]"" Q BGPLPED  ;
  1. TOMREF ; 
  1.  ;EP - now check all refusals of these education topics
  1.  S G="",X=0 F  S X=$O(^AUPNPREF("AA",P,9999999.09,X)) Q:X=""!(G]"")  D
  1.  .S D=0 F  S D=$O(^AUPNPREF("AA",P,9999999.09,X,D)) Q:D=""!(G]"")  D
  1.  ..S I=0 F  S I=$O(^AUPNPREF("AA",P,9999999.09,X,D,I)) Q:I'=+I!(G]"")  D
  1.  ...S Z=$P($G(^AUPNPREF(I,0)),U,3)
  1.  ...Q:Z=""
  1.  ...I Z<BDATE Q
  1.  ...I Z>EDATE Q
  1.  ...S Y=$P($G(^AUTTEDT(X,0)),U,2)
  1.  ...I Y'="TO-M" Q
  1.  ...S G=Z_U_"ref "_Y
  1.  Q G
  1. GETALLHF ;
  1.  S C=$O(^AUTTHF("B","TOBACCO",0)) ;ien of category passed
  1.  I '$G(C) Q
  1.  NEW ED,BD
  1.  S ED=$$FMADD^XLFDT(BGPBDATE,180)
  1.  S (H,D)=0 K O
  1.  F  S H=$O(^AUTTHF("AC",C,H))  Q:'+H  D
  1.  .Q:'$D(^AUPNVHF("AA",DFN,H))
  1.  .S D="" F  S D=$O(^AUPNVHF("AA",DFN,H,D)) Q:D'=+D  D
  1.  ..Q:(9999999-D)>ED  ;after time frame
  1.  ..Q:(9999999-D)<BGPBDX  ;before time frame
  1.  ..I $D(BGPTOBS(D)),$P(BGPTOBS(D),U,2)["CESSATION" Q
  1.  ..I $D(BGPTOBS(D)),$P(BGPTOBS(D),U,2)["CURRENT SMOKE",$P(^AUTTHF(H,0),U)'["CESSATION" Q
  1.  ..S BGPTOBS(D)=$O(^AUPNVHF("AA",DFN,H,D,""))_U_$P(^AUTTHF(H,0),U)
  1.  .Q
  1.  ;NOW if there are multiples on the same day, take the cessation one, if no cessation one, take the current smoker on
  1.  S D=$O(BGPTOBS(0)) I 'D S BGPTOBS="" Q
  1.  S D=BGPTOBS(D)_U_(9999999-D)
  1.  K BGPTOBS
  1.  S BGPTOBS=D
  1.  Q
  1. QUIT(P,BD,ED) ;
  1.  NEW Y,X,G,T
  1.  S Y=$$LASTDXI^BGP0UTL1(P,"305.13",BD,ED)
  1.  I Y Q 1_U_"QUIT: POV 305.13 "_$$DATE^BGP0UTL($P(Y,U,3))
  1.  S Y=$$LASTDXI^BGP0UTL1(P,"V15.82",BD,ED)
  1.  I Y Q 1_U_"QUIT: POV V15.82 "_$$DATE^BGP0UTL($P(Y,U,3))
  1.  S X=0,G="" F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D
  1.  .Q:$P(^AUPNPROB(X,0),U,12)'="A"
  1.  .Q:$P(^AUPNPROB(X,0),U,3)>ED
  1.  .Q:$P(^AUPNPROB(X,0),U,3)<BD
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .S T=$P($$ICDDX^ICDCODE(Y),U,2)
  1.  .I T'="V15.82",T'="305.13" Q
  1.  .S G=1_U_"QUIT: PL "_$P(^ICD9(Y,0),U)_" "_$$DATE^BGP0UTL($P(^AUPNPROB(X,0),U,3))
  1.  I G Q G
  1.  S G=$$LASTHF^BGP0D7(P,"TOBACCO",BD,ED)
  1.  I $P(G,U)["PREVIOUS" Q 1_U_"QUIT: HF: "_$P(G,U,1)_U_" "_$P(G,U,2)
  1.  Q ""
  1.  ;
  1. I91 ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=0
  1.  K BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ,BGPTOM,BGPTOBS,BGPTC1,BGPTOBD,BGPQ
  1.  S (BGPTUHF,BGPTUQ,BGPTU,BGPTUC,BGPREM,BGPTOBD,BGPTOBX,BGPTC,BGPTC1,BGPQ)=""
  1.  I 'BGPACTUP S BGPSTOP=1 Q  ;must be at least user pop
  1.  D NEWSTUFF Q
  1.  ;
  1. NEWSTUFF ;new stuff
  1.  ;BGPD6 - is a tobacco user or user in cessation
  1.  ;BGPD7 - active clinical tobacco user or user in cessation
  1.  ;BGPD8 - ditto, less than 12
  1.  ;BGPD9 - ditto, 12-17
  1.  ;BGPD10 - ditto over 17
  1.  K BGPTOBS
  1.  S BGPBDX=$$FMADD^XLFDT(BGPBDATE,-180) D GETALLHF
  1.  I BGPTOBS]"" D  G SET
  1.  .I $P(BGPTOBS,U,2)["CESSATION" S BGPTUC=1,BGPTUQ=1,BGPTU=1,BGPTOBD=$P(BGPTOBS,U,3),BGPTOBX=$P(BGPTOBS,U,2)  ;cessation and quit
  1.  .I $P(BGPTOBS,U,2)["CURRENT" S BGPTU=1,BGPTOBD=$P(BGPTOBS,U,3),BGPTOBX=$P(BGPTOBS,U,2)
  1.  .I $P(BGPTOBS,U,2)]"",'BGPTU D
  1.  ..S X=$P(BGPTOBS,U,3)
  1.  ..S Y=$$CPTI^BGP0DU(DFN,$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180),+$$CODEN^ICPTCOD("1034F"))
  1.  ..I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT: 1034F" Q
  1.  ..S Y=$$CPTI^BGP0DU(DFN,$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180),+$$CODEN^ICPTCOD("1035F"))
  1.  ..I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT: 1035F"
  1.  ;expand the time range
  1.  S BGPBDX=$$DOB^AUPNPAT(DFN) D GETALLHF
  1.  ;
  1.  I BGPTOBS="" D  G SET
  1.  .S Y=$$LASTDX^BGP0UTL1(DFN,"BGP TOBACCO USER DXS",$$FMADD^XLFDT(BGPBDATE,-180),$$FMADD^XLFDT(BGPBDATE,180))
  1.  .I Y S BGPTU=1,BGPTOBD=$P(Y,U,3),BGPTOBX=$P(Y,U,2) Q
  1.  .S Y=$$CPT^BGP0DU(DFN,$$FMADD^XLFDT(BGPBDATE,-180),$$FMADD^XLFDT(BGPBDATE,180),$O(^ATXAX("B","BGP TOBACCO USER CPTS",0)),6)
  1.  .I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX=$P(Y,U,3) Q
  1.  ;
  1.  I $P(BGPTOBS,U,2)["CURRENT" D  S:'BGPREM BGPTU=1,BGPTOBD=$P(BGPTOBS,U,3),BGPTOBX=$P(BGPTOBS,U,2) S:$P(BGPTOBS,U,2)["CESSATION" BGPTUC=1,BGPTUQ=1 G SET
  1.  .S X=$P(BGPTOBS,U,3)
  1.  .S Y=$$LASTDXI^BGP0UTL1(DFN,"305.13",$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180))
  1.  .I Y S BGPREM=1 Q
  1.  .S Y=$$LASTDXI^BGP0UTL1(DFN,"V15.82",$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180))
  1.  .I Y S BGPREM=1 Q
  1.  .S BGPBDX=$$FMADD^XLFDT(BGPBDATE,-180),BGPEDX=$$FMADD^XLFDT(BGPBDATE,180)
  1.  .S T=$O(^ATXAX("B","BGP TOBACCO USER DXS",0))
  1.  .S X=0,G="" F  S X=$O(^AUPNPROB("AC",DFN,X)) Q:X'=+X!(BGPREM)  D
  1.  ..Q:$P(^AUPNPROB(X,0),U,12)'="A"
  1.  ..Q:$P(^AUPNPROB(X,0),U,3)>BGPEDX
  1.  ..Q:$P(^AUPNPROB(X,0),U,3)<BGPBDX
  1.  ..S Y=$P(^AUPNPROB(X,0),U)
  1.  ..Q:'$$ICD^ATXCHK(Y,T,9)
  1.  ..S BGPREM=1
  1.  .Q
  1.  ;
  1.  S X=$P(BGPTOBS,U,3)
  1.  S Y=$$CPTI^BGP0DU(DFN,$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180),+$$CODEN^ICPTCOD("1034F"))
  1.  I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT: 1034F" G SET
  1.  S Y=$$CPTI^BGP0DU(DFN,$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180),+$$CODEN^ICPTCOD("1035F"))
  1.  I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT: 1035F"
  1.  ;
  1.  ;BGPTU - tobacco user  BGPTUQ - quit tobacco use BGPTUC - tobacco user in cessation
  1. SET ;
  1.  I 'BGPTU S BGPSTOP=1 D KVARS Q  ;not in this denominator at all
  1.  S BGPD6=1
  1.  I BGPD6,BGPACTCL S BGPD7=1
  1.  I BGPD7,BGPAGEB<12 S BGPD8=1
  1.  I BGPD7,BGPAGEB>11,BGPAGEB<18 S BGPD9=1
  1.  I BGPD7,BGPAGEB>17 S BGPD10=1
  1.  ;get numerator stuff
  1.  ;BGPN6=tobacco cessation counseling  bgpn7 - REFUSED counseling  
  1.  I 'BGPTUC S BGPTC1=$$PED^BGP0D711(DFN,$$FMADD^XLFDT(BGPBDATE,-180),BGPEDATE,1)
  1.  I $P(BGPTC1,U)]"" S BGPN6=1 I $P(BGPTC1,U,2)["ref" S BGPN7=1
  1.  ;BGPN8 - quit   bgpn9-cessation
  1.  S BGPQ=$$QUIT(DFN,$$FMADD^XLFDT(BGPTOBD,1),BGPEDATE)  ;any quit after BGPTOBD
  1.  I BGPQ S BGPN8=1
  1.  I BGPTUQ S BGPN8=1
  1.  I BGPN8,BGPTUQ S BGPN9=1
  1.  I BGPN6!(BGPN8) S BGPN10=1
  1.  ;SET BGPVALUE
  1.  S BGPVALUE=$S(BGPRTYPE=3:"",1:"")_$S(BGPD7:";AC",1:"")_" TOB USER: "_$$DATE^BGP0UTL(BGPTOBD)
  1.  D
  1.  .S BGPVALUE=BGPVALUE_"|||"_$S($P(BGPTC1,U):";COUNSELING: "_$$DATE^BGP0UTL($P(BGPTC1,U))_" "_$P(BGPTC1,U,2),1:"")
  1.  .I BGPN8,BGPQ S BGPVALUE=BGPVALUE_";"_$P(BGPQ,U,2)_" "_$P(BGPQ,U,3)
  1.  .I BGPN8,'BGPQ S BGPVALUE=BGPVALUE_";QUIT - CESSATION"
  1. KVARS ;
  1.  K BGPQ,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPQ,BGPALLED,BGPTQ,BGPTC
  1.  K BGPTC1,BGPTOB,BGPSDX,BGP1320,BGPTOM,BGPTOBS,BGPTUHF,BGPTU,BGPTUC,BGPTUQ,BGPTOBD,BGPREM
  1.  Q