- 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 ""
