BGPDB ; IHS/CMI/LAB - indicator B ;
;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
;
IB ;EP ;EP - indicator B
;Q:'$D(BGPIND(28))
Q:BGPAGEB<51
S BGPSEX=$P(^DPT(DFN,0),U,2),BGPSEX=$S(BGPSEX="M":1,1:2)
D SAGE(BGPRPT,$S(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),19,BGPSEX,1)
S BGPFOB=$$FOB(DFN,BGPEDATE)
I BGPFOB]"" D SAGE(BGPRPT,$S(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),20,BGPSEX,1)
S BGPRECT=$$RECT(DFN,BGPEDATE)
I BGPRECT]"" D SAGE(BGPRPT,$S(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),23,BGPSEX,1)
S BGPDRE=$$DRE(DFN,BGPEDATE)
S BGPSIG=$$SIG(DFN,BGPEDATE)
S BGPCOLO=$$COLO(DFN,BGPEDATE)
I BGPDRE]"",BGPSIG]"" D SAGE(BGPRPT,$S(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),21,BGPSEX,1)
I BGPDRE]"",BGPCOLO]"" D SAGE(BGPRPT,$S(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),22,BGPSEX,1)
I $D(BGPLIST(28)),BGPTIME=1 S ^XTMP("BGPD",BGPJ,BGPH,"LIST",28,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),BGPAGEE,DFN)=BGPFOB_" "_BGPDRE_" "_BGPSIG_" "_BGPCOLO
Q
SAGE(R,N,P,S,V) ;set age into file
I 'V Q ;no value
NEW X,Y
S X=$P($G(^BGPD(R,N)),U,P)
S $P(X,"!",S)=$P(X,"!",S)+V
S $P(^BGPD(R,N),U,P)=X
Q
S(R,N,P,V) ;
I 'V Q ;no value to add
S $P(^BGPD(R,N),U,P)=$P($G(^BGPD(R,N)),U,P)+V
Q
SIG(P,EDATE) ;
NEW BGPG,X,%,E,R,V,BDATE
K BGPG
S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
K BGPG S %=P_"^LAST PROCEDURE 45.24;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "SIG"
K BGPG S R="" F %=1:1 S T=$T(SIGCPTS+%^BGPDU) Q:$P(T,";;",2)=""!(R) S T=$P(T,";;",2),T=+$$CODEN^ICPTCOD(T) I T S E=$$CPTI^BGPDU(P,BDATE,EDATE,T) I E S R=1
Q $S(R:"SIG",1:"")
COLO(P,EDATE) ;
NEW BGPG,X,%,E,R,V,BDATE
K BGPG
S BDATE=$$FMADD^XLFDT(EDATE,10*(-365))
K BGPG S %=P_"^LAST PROCEDURE 45.21;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "COLO"
K BGPG S %=P_"^LAST PROCEDURE 45.22;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "COLO"
K BGPG S %=P_"^LAST PROCEDURE 45.23;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "COLO"
K BGPG S %=P_"^LAST PROCEDURE 45.25;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "COLO"
K BGPG S R="" F %=1:1 S T=$T(SIGCPTS+%^BGPDU) Q:$P(T,";;",2)=""!(R) S T=$P(T,";;",2),T=+$$CODEN^ICPTCOD(T) I T S E=$$CPTI^BGPDU(P,BDATE,EDATE,T) I E S R=1
Q $S(R:"SIG",1:"")
DRE(P,EDATE) ;
NEW BGPG,X,%,E,R,V,BDATE
K BGPG
S BDATE=$$FMADD^XLFDT(EDATE,(5*-365))
K BGPG S %=P_"^LAST PROCEDURE 89.34;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "DRE"
S %=P_"^LAST EXAM RECTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "DRE"
Q ""
RECT(P,EDATE) ;
NEW BGPG,X,%,E,R,V,BDATE
K BGPG
S BDATE=$$FMADD^XLFDT(EDATE,(1*-365))
K BGPG S %=P_"^LAST PROCEDURE 89.34;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "DRE"
S %=P_"^LAST EXAM RECTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "RECTAL EXAM"
Q ""
FOB(P,EDATE) ;
NEW BGPG,X,%,E,R,V,BDATE
K BGPG
S BDATE=$$FMADD^XLFDT(EDATE,-365)
S %=P_"^LAST LAB [BGP GPRA FOB TESTS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "FOB"
S E=+$$CODEN^ICPTCOD(82270) I E,$$CPTI^BGPDU(P,BDATE,EDATE,E) Q "FOB"
Q ""
BGPDB ; IHS/CMI/LAB - indicator B ;
+1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
+2 ;
IB ;EP ;EP - indicator B
+1 ;Q:'$D(BGPIND(28))
+2 IF BGPAGEB<51
QUIT
+3 SET BGPSEX=$PIECE(^DPT(DFN,0),U,2)
SET BGPSEX=$SELECT(BGPSEX="M":1,1:2)
+4 DO SAGE(BGPRPT,$SELECT(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),19,BGPSEX,1)
+5 SET BGPFOB=$$FOB(DFN,BGPEDATE)
+6 IF BGPFOB]""
DO SAGE(BGPRPT,$SELECT(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),20,BGPSEX,1)
+7 SET BGPRECT=$$RECT(DFN,BGPEDATE)
+8 IF BGPRECT]""
DO SAGE(BGPRPT,$SELECT(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),23,BGPSEX,1)
+9 SET BGPDRE=$$DRE(DFN,BGPEDATE)
+10 SET BGPSIG=$$SIG(DFN,BGPEDATE)
+11 SET BGPCOLO=$$COLO(DFN,BGPEDATE)
+12 IF BGPDRE]""
IF BGPSIG]""
DO SAGE(BGPRPT,$SELECT(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),21,BGPSEX,1)
+13 IF BGPDRE]""
IF BGPCOLO]""
DO SAGE(BGPRPT,$SELECT(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),22,BGPSEX,1)
+14 IF $DATA(BGPLIST(28))
IF BGPTIME=1
SET ^XTMP("BGPD",BGPJ,BGPH,"LIST",28,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),BGPAGEE,DFN)=BGPFOB_" "_BGPDRE_" "_BGPSIG_" "_BGPCOLO
+15 QUIT
SAGE(R,N,P,S,V) ;set age into file
+1 ;no value
IF 'V
QUIT
+2 NEW X,Y
+3 SET X=$PIECE($GET(^BGPD(R,N)),U,P)
+4 SET $PIECE(X,"!",S)=$PIECE(X,"!",S)+V
+5 SET $PIECE(^BGPD(R,N),U,P)=X
+6 QUIT
S(R,N,P,V) ;
+1 ;no value to add
IF 'V
QUIT
+2 SET $PIECE(^BGPD(R,N),U,P)=$PIECE($GET(^BGPD(R,N)),U,P)+V
+3 QUIT
SIG(P,EDATE) ;
+1 NEW BGPG,X,%,E,R,V,BDATE
+2 KILL BGPG
+3 SET BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
+4 KILL BGPG
SET %=P_"^LAST PROCEDURE 45.24;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+5 IF $DATA(BGPG(1))
QUIT "SIG"
+6 KILL BGPG
SET R=""
FOR %=1:1
SET T=$TEXT(SIGCPTS+%^BGPDU)
IF $PIECE(T,";;",2)=""!(R)
QUIT
SET T=$PIECE(T,";;",2)
SET T=+$$CODEN^ICPTCOD(T)
IF T
SET E=$$CPTI^BGPDU(P,BDATE,EDATE,T)
IF E
SET R=1
+7 QUIT $SELECT(R:"SIG",1:"")
COLO(P,EDATE) ;
+1 NEW BGPG,X,%,E,R,V,BDATE
+2 KILL BGPG
+3 SET BDATE=$$FMADD^XLFDT(EDATE,10*(-365))
+4 KILL BGPG
SET %=P_"^LAST PROCEDURE 45.21;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+5 IF $DATA(BGPG(1))
QUIT "COLO"
+6 KILL BGPG
SET %=P_"^LAST PROCEDURE 45.22;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+7 IF $DATA(BGPG(1))
QUIT "COLO"
+8 KILL BGPG
SET %=P_"^LAST PROCEDURE 45.23;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+9 IF $DATA(BGPG(1))
QUIT "COLO"
+10 KILL BGPG
SET %=P_"^LAST PROCEDURE 45.25;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+11 IF $DATA(BGPG(1))
QUIT "COLO"
+12 KILL BGPG
SET R=""
FOR %=1:1
SET T=$TEXT(SIGCPTS+%^BGPDU)
IF $PIECE(T,";;",2)=""!(R)
QUIT
SET T=$PIECE(T,";;",2)
SET T=+$$CODEN^ICPTCOD(T)
IF T
SET E=$$CPTI^BGPDU(P,BDATE,EDATE,T)
IF E
SET R=1
+13 QUIT $SELECT(R:"SIG",1:"")
DRE(P,EDATE) ;
+1 NEW BGPG,X,%,E,R,V,BDATE
+2 KILL BGPG
+3 SET BDATE=$$FMADD^XLFDT(EDATE,(5*-365))
+4 KILL BGPG
SET %=P_"^LAST PROCEDURE 89.34;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+5 IF $DATA(BGPG(1))
QUIT "DRE"
+6 SET %=P_"^LAST EXAM RECTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+7 IF $DATA(BGPG(1))
QUIT "DRE"
+8 QUIT ""
RECT(P,EDATE) ;
+1 NEW BGPG,X,%,E,R,V,BDATE
+2 KILL BGPG
+3 SET BDATE=$$FMADD^XLFDT(EDATE,(1*-365))
+4 KILL BGPG
SET %=P_"^LAST PROCEDURE 89.34;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+5 IF $DATA(BGPG(1))
QUIT "DRE"
+6 SET %=P_"^LAST EXAM RECTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+7 IF $DATA(BGPG(1))
QUIT "RECTAL EXAM"
+8 QUIT ""
FOB(P,EDATE) ;
+1 NEW BGPG,X,%,E,R,V,BDATE
+2 KILL BGPG
+3 SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+4 SET %=P_"^LAST LAB [BGP GPRA FOB TESTS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+5 IF $DATA(BGPG(1))
QUIT "FOB"
+6 SET E=+$$CODEN^ICPTCOD(82270)
IF E
IF $$CPTI^BGPDU(P,BDATE,EDATE,E)
QUIT "FOB"
+7 QUIT ""
