- BGPDPARP ; IHS/CMI/LAB - IHS gpra print ;
- ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
- ;
- ;
- PRINT ;EP
- S BGPGPG=0
- S BGPQUIT=""
- D AREACP^BGPDPH
- S BGPQUIT="",BGPGPG=0,BGPRPT=0
- S BGPSUMR=1
- D ^BGPAP
- Q:BGPQUIT
- K BGPSUMR
- D PRINT1^BGPDP
- Q
- ;
- C4C5 ;EP - inds c4 and c5 sum report
- C5 ;
- D HEADER^BGPDPH
- W !!,"C5 ",!,"Increase the quality, availability, and effectiveness of educational services",!,"designed to prevent disease and improve the health and quality of life."
- W !,"Increase the proportion of persons who are provided patient education",!,"on diet and exercise.",!
- W !,"Provision of Diet and Exercise Education",!
- D H
- S BGPRPT=0 F S BGPRPT=$O(BGPSUL(BGPRPT)) Q:BGPRPT'=+BGPRPT!(BGPQUIT) D
- .S BGPCYD=$P($$V(BGPRPT,29,1),"!",1)+$P($$V(BGPRPT,29,1),"!",2),BGPCYN=$P($$V(BGPRPT,29,10),"!",1)+$P($$V(BGPRPT,29,10),"!",2),BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")
- .S BGP98D=$P($$V(BGPRPT,99,1),"!",1)+$P($$V(BGPRPT,99,1),"!",2),BGP98N=$P($$V(BGPRPT,99,10),"!",1)+$P($$V(BGPRPT,99,10),"!",2),BGP98P=$S(BGP98D:((BGP98N/BGP98D)*100),1:"")
- .S BGPPRD=$P($$V(BGPRPT,59,1),"!",1)+$P($$V(BGPRPT,59,1),"!",2),BGPPRN=$P($$V(BGPRPT,59,10),"!",1)+$P($$V(BGPRPT,59,10),"!",2),BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")
- .D LOCW
- Q
- CALC(N,O) ;ENTRY POINT
- ;N is new
- ;O is old
- NEW Z
- I O=0!(N=0)!(O="")!(N="") Q "**"
- NEW X,X2,X3
- S X=N,X2=1,X3=0 D COMMA^%DTC S N=X
- S X=O,X2=1,X3=0 D COMMA^%DTC S O=X
- I +O=0 Q "**"
- S Z=(((N-O)/O)*100),Z=$FN(Z,"+,",1)
- Q Z
- H ;write header
- W !?44,"% CHANGE",?62,"% CHANGE",!?44,"FROM BASE YR",?62,"FROM PREV YR"
- Q
- LOCW ;
- I $Y>(IOSL-3) D HEADER^BGPDPH Q:BGPQUIT
- W !?3,$P(^BGPD(BGPRPT,0),U,5)
- S X=$P(^BGPD(BGPRPT,0),U,5)
- I X="" W ?11,"?????" Q
- S X=$O(^AUTTLOC("C",X,0))
- I X="" W ?11,"?????" Q
- W ?11,$E($P(^DIC(4,X,0),U),1,20)
- S BGPX=$J($$CALC(BGPCYP,BGP98P),6),$E(BGPX,20)=$J($$CALC(BGPCYP,BGPPRP),6)
- W ?46,BGPX
- Q
- V(R,N,P) ;
- NEW Y
- I $G(BGPAREAA),'$G(BGPSUMR) G VA
- Q $P($G(^BGPD(R,N)),U,P)
- VA ;
- NEW X,C,V,MT,FT,M,F,B S X=0,C="" F S X=$O(BGPSUL(X)) Q:X'=+X D
- .S V=$P($G(^BGPD(X,N)),U,P)
- .I C="" S C=V Q
- .S MT=$P(C,"!"),FT=$P(C,"!",2),M=$P(V,"!"),F=$P(V,"!",2)
- .F B=1:1:6 S $P(MT,"~",B)=$P(MT,"~",B)+$P(M,"~",B)
- .F B=1:1:6 S $P(FT,"~",B)=$P(FT,"~",B)+$P(F,"~",B)
- .S C=MT_"!"_FT
- .Q
- Q C
- C(X,X2,X3) ;
- D COMMA^%DTC
- Q X
- BGPDPARP ; IHS/CMI/LAB - IHS gpra print ;
- +1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
- +2 ;
- +3 ;
- PRINT ;EP
- +1 SET BGPGPG=0
- +2 SET BGPQUIT=""
- +3 DO AREACP^BGPDPH
- +4 SET BGPQUIT=""
- SET BGPGPG=0
- SET BGPRPT=0
- +5 SET BGPSUMR=1
- +6 DO ^BGPAP
- +7 IF BGPQUIT
- QUIT
- +8 KILL BGPSUMR
- +9 DO PRINT1^BGPDP
- +10 QUIT
- +11 ;
- C4C5 ;EP - inds c4 and c5 sum report
- C5 ;
- +1 DO HEADER^BGPDPH
- +2 WRITE !!,"C5 ",!,"Increase the quality, availability, and effectiveness of educational services",!,"designed to prevent disease and improve the health and quality of life."
- +3 WRITE !,"Increase the proportion of persons who are provided patient education",!,"on diet and exercise.",!
- +4 WRITE !,"Provision of Diet and Exercise Education",!
- +5 DO H
- +6 SET BGPRPT=0
- FOR
- SET BGPRPT=$ORDER(BGPSUL(BGPRPT))
- IF BGPRPT'=+BGPRPT!(BGPQUIT)
- QUIT
- Begin DoDot:1
- +7 SET BGPCYD=$PIECE($$V(BGPRPT,29,1),"!",1)+$PIECE($$V(BGPRPT,29,1),"!",2)
- SET BGPCYN=$PIECE($$V(BGPRPT,29,10),"!",1)+$PIECE($$V(BGPRPT,29,10),"!",2)
- SET BGPCYP=$SELECT(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")
- +8 SET BGP98D=$PIECE($$V(BGPRPT,99,1),"!",1)+$PIECE($$V(BGPRPT,99,1),"!",2)
- SET BGP98N=$PIECE($$V(BGPRPT,99,10),"!",1)+$PIECE($$V(BGPRPT,99,10),"!",2)
- SET BGP98P=$SELECT(BGP98D:((BGP98N/BGP98D)*100),1:"")
- +9 SET BGPPRD=$PIECE($$V(BGPRPT,59,1),"!",1)+$PIECE($$V(BGPRPT,59,1),"!",2)
- SET BGPPRN=$PIECE($$V(BGPRPT,59,10),"!",1)+$PIECE($$V(BGPRPT,59,10),"!",2)
- SET BGPPRP=$SELECT(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")
- +10 DO LOCW
- End DoDot:1
- +11 QUIT
- CALC(N,O) ;ENTRY POINT
- +1 ;N is new
- +2 ;O is old
- +3 NEW Z
- +4 IF O=0!(N=0)!(O="")!(N="")
- QUIT "**"
- +5 NEW X,X2,X3
- +6 SET X=N
- SET X2=1
- SET X3=0
- DO COMMA^%DTC
- SET N=X
- +7 SET X=O
- SET X2=1
- SET X3=0
- DO COMMA^%DTC
- SET O=X
- +8 IF +O=0
- QUIT "**"
- +9 SET Z=(((N-O)/O)*100)
- SET Z=$FNUMBER(Z,"+,",1)
- +10 QUIT Z
- H ;write header
- +1 WRITE !?44,"% CHANGE",?62,"% CHANGE",!?44,"FROM BASE YR",?62,"FROM PREV YR"
- +2 QUIT
- LOCW ;
- +1 IF $Y>(IOSL-3)
- DO HEADER^BGPDPH
- IF BGPQUIT
- QUIT
- +2 WRITE !?3,$PIECE(^BGPD(BGPRPT,0),U,5)
- +3 SET X=$PIECE(^BGPD(BGPRPT,0),U,5)
- +4 IF X=""
- WRITE ?11,"?????"
- QUIT
- +5 SET X=$ORDER(^AUTTLOC("C",X,0))
- +6 IF X=""
- WRITE ?11,"?????"
- QUIT
- +7 WRITE ?11,$EXTRACT($PIECE(^DIC(4,X,0),U),1,20)
- +8 SET BGPX=$JUSTIFY($$CALC(BGPCYP,BGP98P),6)
- SET $EXTRACT(BGPX,20)=$JUSTIFY($$CALC(BGPCYP,BGPPRP),6)
- +9 WRITE ?46,BGPX
- +10 QUIT
- V(R,N,P) ;
- +1 NEW Y
- +2 IF $GET(BGPAREAA)
- IF '$GET(BGPSUMR)
- GOTO VA
- +3 QUIT $PIECE($GET(^BGPD(R,N)),U,P)
- VA ;
- +1 NEW X,C,V,MT,FT,M,F,B
- SET X=0
- SET C=""
- FOR
- SET X=$ORDER(BGPSUL(X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +2 SET V=$PIECE($GET(^BGPD(X,N)),U,P)
- +3 IF C=""
- SET C=V
- QUIT
- +4 SET MT=$PIECE(C,"!")
- SET FT=$PIECE(C,"!",2)
- SET M=$PIECE(V,"!")
- SET F=$PIECE(V,"!",2)
- +5 FOR B=1:1:6
- SET $PIECE(MT,"~",B)=$PIECE(MT,"~",B)+$PIECE(M,"~",B)
- +6 FOR B=1:1:6
- SET $PIECE(FT,"~",B)=$PIECE(FT,"~",B)+$PIECE(F,"~",B)
- +7 SET C=MT_"!"_FT
- +8 QUIT
- End DoDot:1
- +9 QUIT C
- C(X,X2,X3) ;
- +1 DO COMMA^%DTC
- +2 QUIT X
