- BGP6PDL2 ; IHS/CMI/LAB - print ind 1 ;
- ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
- ;
- ;this routine for Measure I14 ONLY
- I10 ;EP
- D:'$G(BGPSUMON) H1^BGP6PDL1
- S BGPORDP=$P(^BGPINDM(BGPIC,12),U,6) F BGPORDP1=1:1:$P(^BGPINDM(BGPIC,0),U,13) S BGPPC1=BGPORDP_"."_BGPORDP1 D PI^BGP6PDL1
- K BGPNODEN
- F BGPPC1=$P(^BGPINDM(BGPIC,12),U,6)_".8" D PI
- Q
- I11 ;EP
- S BGPORXX=$P(^BGPINDM(BGPIC,12),U,6)
- D:'$G(BGPSUMON) H1 S BGPNODEN=1
- F BGPPC1=BGPORXX_".1" D PI^BGP6PDL1
- S BGPNODEN=1
- F BGPPC1=BGPORXX_".2" D PI
- K BGPNODEN
- F BGPPC1=BGPORXX_".3" D PI
- Q
- ISTI ;EP
- S BGPORXX=$P(^BGPINDM(BGPIC,12),U,6)
- D:'$G(BGPSUMON) H1 S BGPNODEN=1
- F BGPPC1=BGPORXX_".1",BGPORXX_".2",BGPORXX_".3" D PI
- S BGPNODEN=1
- F BGPPC1=BGPORXX_".4" D PI ;
- ;
- K BGPNODEN
- F BGPPC1=BGPORXX_".5",BGPORXX_".6",BGPORXX_".7" D PI^BGP6PDL1 ;
- ;
- Q
- F BGPPC1=BGPORXX_".10",BGPORXX_".11",BGPORXX_".12" D PI^BGP6PDL1 ;
- ;
- F BGPPC1=BGPORXX_".13",BGPORXX_".14",BGPORXX_".15" D PI^BGP6PDL1 ;
- ;
- F BGPPC1=BGPORXX_".16",BGPORXX_".17",BGPORXX_".18" D PI^BGP6PDL1 ;
- ;
- F BGPPC1=BGPORXX_".19",BGPORXX_".20",BGPORXX_".21" D PI^BGP6PDL1 ;
- ;
- ;USER POP
- D S(" ",1,1)
- S BGPNODEN=1
- F BGPPC1=BGPORXX_".22",BGPORXX_".23",BGPORXX_".24" D PI ;
- ;
- S BGPNODEN=1
- F BGPPC1=BGPORXX_".25",BGPORXX_".26",BGPORXX_".27" D PI ;
- K BGPNODEN
- F BGPPC1=BGPORXX_".28",BGPORXX_".29",BGPORXX_".30" D PI^BGP6PDL1 ;
- ;
- F BGPPC1=BGPORXX_".31",BGPORXX_".32",BGPORXX_".33" D PI^BGP6PDL1 ;
- ;
- F BGPPC1=BGPORXX_".34",BGPORXX_".35",BGPORXX_".36" D PI^BGP6PDL1 ;
- ;
- F BGPPC1=BGPORXX_".37",BGPORXX_".38",BGPORXX_".39" D PI^BGP6PDL1 ;
- ;
- F BGPPC1=BGPORXX_".40",BGPORXX_".41",BGPORXX_".42" D PI^BGP6PDL1 ;
- ;
- Q
- IPC ;EP
- S BGPORXX=$P(^BGPINDM(BGPIC,12),U,6)
- D:'$G(BGPSUMON) H1 S BGPNODEN=1
- F BGPPC1=BGPORXX_".1",BGPORXX_".2",BGPORXX_".3",BGPORXX_".4" D PI ;
- ;
- S BGPNODEN=1
- F BGPPC1=BGPORXX_".5",BGPORXX_".6",BGPORXX_".7",BGPORXX_".8" D PI ;
- S BGPORDP=$P(^BGPINDM(BGPIC,12),U,6) F BGPORDP1=9:1:17 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI^BGP6PDL1
- Q
- PI ;EP
- S BGPDENP=0
- K BGPDHOLD
- K BGPCYP,BGPBLP,BGPPRP
- S BGPPC2=0 F S BGPPC2=$O(^BGPINDMC("AB",BGPPC1,BGPPC2)) Q:BGPPC2="" S BGPPC=$O(^BGPINDMC("AB",BGPPC1,BGPPC2,0)) D PI1
- Q
- PI1 ;EP
- K BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
- Q:'$$CHECK^BGP6DP1E(BGPPC)
- ;get numerator value of measure and calc %
- S BGPDF=$P(^BGPINDMC(BGPPC,0),U,9)
- S BGPNP=$P(^DD(90556.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- S BGPCYD=$$V^BGP6DP1C(1,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP6DP1C(1,N,P)
- S BGPPRD=$$V^BGP6DP1C(2,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP6DP1C(2,N,P)
- S BGPBLD=$$V^BGP6DP1C(3,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP6DP1C(3,N,P)
- S BGPNF=$P(^BGPINDMC(BGPPC,0),U,9)
- S BGPNP=$P(^DD(90556.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- D SETN
- I $P($G(^BGPINDMC(BGPPC,14)),U) D
- .S ^TMP($J,"SUMMARYDEL",$P(^BGPSCAT($P(^BGPINDMC(BGPPC,14),U,5),0),U,2),$P(^BGPINDMC(BGPPC,14),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- .Q:'$G(BGPAREAA)
- .S X=0 F S X=$O(BGPSDP(X)) Q:X'=+X D ;SDPX
- ..S ^TMP($J,"SUMMARYDEL DETAIL PAGE",$P(^BGPSCAT($P(^BGPINDMC(BGPPC,14),U,5),0),U,2),$P(^BGPINDMC(BGPPC,14),U,6),BGPPC,X)=$P($G(BGPSDP(X,1)),U,2)_U_$P($G(BGPSDP(X,2)),U,2)_U_$P($G(BGPSDP(X,3)),U,2)_U_BGPCYN
- ;NON
- I $P($G(^BGPINDMC(BGPPC,15)),U) D
- .S ^TMP($J,"SUMMARYDEL NON",$P(^BGPSCAT($P(^BGPINDMC(BGPPC,15),U,5),0),U,3),$P(^BGPINDMC(BGPPC,15),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- .I $G(BGPAREAA) D ;SDPX
- ..S X=0 F S X=$O(BGPSDPN(X)) Q:X'=+X D ;SDPX
- ...S ^TMP($J,"SUMMARYDEL DETAIL PAGE NON",$P(^BGPSCAT($P(^BGPINDMC(BGPPC,15),U,5),0),U,3),$P(^BGPINDMC(BGPPC,15),U,6),BGPPC,X)=$P($G(BGPSDPN(X,1)),U,2)_U_$P($G(BGPSDPN(X,2)),U,2)_U_$P($G(BGPSDPN(X,3)),U,2)_U_BGPCYN
- ;DEVEL
- I $P($G(^BGPINDMC(BGPPC,22)),U) D
- .S ^TMP($J,"SUMMARYDEL DEVEL",$P(^BGPSCAT($P(^BGPINDMC(BGPPC,22),U,5),0),U,3),$P(^BGPINDMC(BGPPC,22),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- .I $G(BGPAREAA) D ;SDPX
- ..S X=0 F S X=$O(BGPSDPD(X)) Q:X'=+X D ;SDPX
- ...S ^TMP($J,"SUMMARYDEL DETAIL PAGE DEVEL",$P(^BGPSCAT($P(^BGPINDMC(BGPPC,22),U,5),0),U,3),$P(^BGPINDMC(BGPPC,22),U,6),BGPPC,X)=$P($G(BGPSDPD(X,1)),U,2)_U_$P($G(BGPSDPD(X,2)),U,2)_U_$P($G(BGPSDPD(X,3)),U,2)_U_BGPCYN
- ;OTHER
- I $P($G(^BGPINDMC(BGPPC,19)),U) D
- .S ^TMP($J,"SUMMARYDEL OTHER",$P(^BGPSCAT($P(^BGPINDMC(BGPPC,19),U,5),0),U,3),$P(^BGPINDMC(BGPPC,19),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- .I $G(BGPAREAA) D ;SDPX
- ..S X=0 F S X=$O(BGPSDPO(X)) Q:X'=+X D ;SDPX
- ...S ^TMP($J,"SUMMARYDEL DETAIL PAGE OTHER",$P(^BGPSCAT($P(^BGPINDMC(BGPPC,19),U,5),0),U,3),$P(^BGPINDMC(BGPPC,19),U,6),BGPPC,X)=$P($G(BGPSDPO(X,1)),U,2)_U_$P($G(BGPSDPO(X,2)),U,2)_U_$P($G(BGPSDPO(X,3)),U,2)_U_BGPCYN
- I BGPROT="D"!(BGPROT="B") D SETSUM^BGP6DP2
- S X=$$LABEL^BGP6UTL1(BGPPC,BGPRTYPE,BGPPTYPE,$G(BGPINDM),"N") D S(X,1,1)
- D H2
- Q
- H2 ;
- S BGPX="",BGPX=BGPCYN,$P(BGPX,U,2)=$S(BGPCYP]"":$$SB($J(BGPCYP,5,1)),1:""),$P(BGPX,U,3)=BGPPRN,$P(BGPX,U,4)=$S(BGPPRP]"":$$SB($J(BGPPRP,5,1)),1:"")
- S $P(BGPX,U,5)=$$SB($J($$CALC(BGPCYN,BGPPRN),6)),$P(BGPX,U,6)=BGPBLN,$P(BGPX,U,7)=$S(BGPBLP]"":$$SB($J(BGPBLP,5,1)),1:"")
- S $P(BGPX,U,8)=$$SB($J($$CALC(BGPCYN,BGPBLN),6))
- D S(BGPX,,2)
- Q
- H1 ;EP
- S Y="REPORT" D S(Y,1,2)
- S Y=" " D S(Y,,3)
- S Y="PREV YR" D S(Y,,4)
- S Y=" " D S(Y,,5)
- S Y="CHG from" D S(Y,,6)
- S Y="BASE" D S(Y,,7)
- S Y=" " D S(Y,,8)
- S Y="CHG from" D S(Y,,9)
- S Y="PERIOD" D S(Y,1,2)
- S Y="PERIOD" D S(Y,,4)
- S Y="PREV YR " D S(Y,,6)
- S Y="PERIOD" D S(Y,,7)
- S Y="BASE " D S(Y,,9)
- Q
- C(X,X2,X3) ;
- D COMMA^%DTC
- Q X
- S(Y,F,P) ;set up array
- I '$G(F) S F=0
- S %=$P(^TMP($J,"BGPDEL",0),U)+F,$P(^TMP($J,"BGPDEL",0),U)=%
- I '$D(^TMP($J,"BGPDEL",%)) S ^TMP($J,"BGPDEL",%)=""
- S $P(^TMP($J,"BGPDEL",%),U,P)=Y
- Q
- CALC(N,O) ;ENTRY POINT
- NEW Z
- S Z=N-O,Z=$FN(Z,"+,",0)
- Q Z
- SB(X) ;EP - Strip leading and trailing blanks from X.
- X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)
- Q X
- SETN ;set numerator fields
- S BGPIIDEL=1,BGPNOSUM=1
- D SETN^BGP6DP1C
- K BGPNOSUM,BGPIIDEL
- S (BGPCYP,BGPPRP,BGPBLP)=""
- Q
- BGP6PDL2 ; IHS/CMI/LAB - print ind 1 ;
- +1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
- +2 ;
- +3 ;this routine for Measure I14 ONLY
- I10 ;EP
- +1 IF '$GET(BGPSUMON)
- DO H1^BGP6PDL1
- +2 SET BGPORDP=$PIECE(^BGPINDM(BGPIC,12),U,6)
- FOR BGPORDP1=1:1:$PIECE(^BGPINDM(BGPIC,0),U,13)
- SET BGPPC1=BGPORDP_"."_BGPORDP1
- DO PI^BGP6PDL1
- +3 KILL BGPNODEN
- +4 FOR BGPPC1=$PIECE(^BGPINDM(BGPIC,12),U,6)_".8"
- DO PI
- +5 QUIT
- I11 ;EP
- +1 SET BGPORXX=$PIECE(^BGPINDM(BGPIC,12),U,6)
- +2 IF '$GET(BGPSUMON)
- DO H1
- SET BGPNODEN=1
- +3 FOR BGPPC1=BGPORXX_".1"
- DO PI^BGP6PDL1
- +4 SET BGPNODEN=1
- +5 FOR BGPPC1=BGPORXX_".2"
- DO PI
- +6 KILL BGPNODEN
- +7 FOR BGPPC1=BGPORXX_".3"
- DO PI
- +8 QUIT
- ISTI ;EP
- +1 SET BGPORXX=$PIECE(^BGPINDM(BGPIC,12),U,6)
- +2 IF '$GET(BGPSUMON)
- DO H1
- SET BGPNODEN=1
- +3 FOR BGPPC1=BGPORXX_".1",BGPORXX_".2",BGPORXX_".3"
- DO PI
- +4 SET BGPNODEN=1
- +5 ;
- FOR BGPPC1=BGPORXX_".4"
- DO PI
- +6 ;
- +7 KILL BGPNODEN
- +8 ;
- FOR BGPPC1=BGPORXX_".5",BGPORXX_".6",BGPORXX_".7"
- DO PI^BGP6PDL1
- +9 ;
- +10 QUIT
- +11 ;
- FOR BGPPC1=BGPORXX_".10",BGPORXX_".11",BGPORXX_".12"
- DO PI^BGP6PDL1
- +12 ;
- +13 ;
- FOR BGPPC1=BGPORXX_".13",BGPORXX_".14",BGPORXX_".15"
- DO PI^BGP6PDL1
- +14 ;
- +15 ;
- FOR BGPPC1=BGPORXX_".16",BGPORXX_".17",BGPORXX_".18"
- DO PI^BGP6PDL1
- +16 ;
- +17 ;
- FOR BGPPC1=BGPORXX_".19",BGPORXX_".20",BGPORXX_".21"
- DO PI^BGP6PDL1
- +18 ;
- +19 ;USER POP
- +20 DO S(" ",1,1)
- +21 SET BGPNODEN=1
- +22 ;
- FOR BGPPC1=BGPORXX_".22",BGPORXX_".23",BGPORXX_".24"
- DO PI
- +23 ;
- +24 SET BGPNODEN=1
- +25 ;
- FOR BGPPC1=BGPORXX_".25",BGPORXX_".26",BGPORXX_".27"
- DO PI
- +26 KILL BGPNODEN
- +27 ;
- FOR BGPPC1=BGPORXX_".28",BGPORXX_".29",BGPORXX_".30"
- DO PI^BGP6PDL1
- +28 ;
- +29 ;
- FOR BGPPC1=BGPORXX_".31",BGPORXX_".32",BGPORXX_".33"
- DO PI^BGP6PDL1
- +30 ;
- +31 ;
- FOR BGPPC1=BGPORXX_".34",BGPORXX_".35",BGPORXX_".36"
- DO PI^BGP6PDL1
- +32 ;
- +33 ;
- FOR BGPPC1=BGPORXX_".37",BGPORXX_".38",BGPORXX_".39"
- DO PI^BGP6PDL1
- +34 ;
- +35 ;
- FOR BGPPC1=BGPORXX_".40",BGPORXX_".41",BGPORXX_".42"
- DO PI^BGP6PDL1
- +36 ;
- +37 QUIT
- IPC ;EP
- +1 SET BGPORXX=$PIECE(^BGPINDM(BGPIC,12),U,6)
- +2 IF '$GET(BGPSUMON)
- DO H1
- SET BGPNODEN=1
- +3 ;
- FOR BGPPC1=BGPORXX_".1",BGPORXX_".2",BGPORXX_".3",BGPORXX_".4"
- DO PI
- +4 ;
- +5 SET BGPNODEN=1
- +6 ;
- FOR BGPPC1=BGPORXX_".5",BGPORXX_".6",BGPORXX_".7",BGPORXX_".8"
- DO PI
- +7 SET BGPORDP=$PIECE(^BGPINDM(BGPIC,12),U,6)
- FOR BGPORDP1=9:1:17
- SET BGPPC1=BGPORDP_"."_BGPORDP1
- DO PI^BGP6PDL1
- +8 QUIT
- PI ;EP
- +1 SET BGPDENP=0
- +2 KILL BGPDHOLD
- +3 KILL BGPCYP,BGPBLP,BGPPRP
- +4 SET BGPPC2=0
- FOR
- SET BGPPC2=$ORDER(^BGPINDMC("AB",BGPPC1,BGPPC2))
- IF BGPPC2=""
- QUIT
- SET BGPPC=$ORDER(^BGPINDMC("AB",BGPPC1,BGPPC2,0))
- DO PI1
- +5 QUIT
- PI1 ;EP
- +1 KILL BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
- +2 IF '$$CHECK^BGP6DP1E(BGPPC)
- QUIT
- +3 ;get numerator value of measure and calc %
- +4 SET BGPDF=$PIECE(^BGPINDMC(BGPPC,0),U,9)
- +5 SET BGPNP=$PIECE(^DD(90556.03,BGPDF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +6 SET BGPCYD=$$V^BGP6DP1C(1,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP6DP1C(1,N,P)
- +7 SET BGPPRD=$$V^BGP6DP1C(2,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP6DP1C(2,N,P)
- +8 SET BGPBLD=$$V^BGP6DP1C(3,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP6DP1C(3,N,P)
- +9 SET BGPNF=$PIECE(^BGPINDMC(BGPPC,0),U,9)
- +10 SET BGPNP=$PIECE(^DD(90556.03,BGPNF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +11 DO SETN
- +12 IF $PIECE($GET(^BGPINDMC(BGPPC,14)),U)
- Begin DoDot:1
- +13 SET ^TMP($JOB,"SUMMARYDEL",$PIECE(^BGPSCAT($PIECE(^BGPINDMC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDMC(BGPPC,14),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +14 IF '$GET(BGPAREAA)
- QUIT
- +15 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDP(X))
- IF X'=+X
- QUIT
- Begin DoDot:2
- +16 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE",$PIECE(^BGPSCAT($PIECE(^BGPINDMC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDMC(BGPPC,14),U,6),BGPPC,X)=$PIECE($GET(BGPSDP(X,1)),U,2)_U_$PIECE($GET(BGPSDP(X,2)),U,2)_U_$PIECE($GET(BGPSDP(X,3)),U,2
- )_U_BGPCYN
- End DoDot:2
- End DoDot:1
- +17 ;NON
- +18 IF $PIECE($GET(^BGPINDMC(BGPPC,15)),U)
- Begin DoDot:1
- +19 SET ^TMP($JOB,"SUMMARYDEL NON",$PIECE(^BGPSCAT($PIECE(^BGPINDMC(BGPPC,15),U,5),0),U,3),$PIECE(^BGPINDMC(BGPPC,15),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +20 ;SDPX
- IF $GET(BGPAREAA)
- Begin DoDot:2
- +21 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDPN(X))
- IF X'=+X
- QUIT
- Begin DoDot:3
- +22 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE NON",$PIECE(^BGPSCAT($PIECE(^BGPINDMC(BGPPC,15),U,5),0),U,3),$PIECE(^BGPINDMC(BGPPC,15),U,6),BGPPC,X)=$PIECE($GET(BGPSDPN(X,1)),U,2)_U_$PIECE($GET(BGPSDPN(X,2)),U,2)_U_$PIECE($GET(BG
- PSDPN(X,3)),U,2)_U_BGPCYN
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +23 ;DEVEL
- +24 IF $PIECE($GET(^BGPINDMC(BGPPC,22)),U)
- Begin DoDot:1
- +25 SET ^TMP($JOB,"SUMMARYDEL DEVEL",$PIECE(^BGPSCAT($PIECE(^BGPINDMC(BGPPC,22),U,5),0),U,3),$PIECE(^BGPINDMC(BGPPC,22),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +26 ;SDPX
- IF $GET(BGPAREAA)
- Begin DoDot:2
- +27 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDPD(X))
- IF X'=+X
- QUIT
- Begin DoDot:3
- +28 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE DEVEL",$PIECE(^BGPSCAT($PIECE(^BGPINDMC(BGPPC,22),U,5),0),U,3),$PIECE(^BGPINDMC(BGPPC,22),U,6),BGPPC,X)=$PIECE($GET(BGPSDPD(X,1)),U,2)_U_$PIECE($GET(BGPSDPD(X,2)),U,2)_U_$PIECE($GET(
- BGPSDPD(X,3)),U,2)_U_BGPCYN
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +29 ;OTHER
- +30 IF $PIECE($GET(^BGPINDMC(BGPPC,19)),U)
- Begin DoDot:1
- +31 SET ^TMP($JOB,"SUMMARYDEL OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDMC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDMC(BGPPC,19),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +32 ;SDPX
- IF $GET(BGPAREAA)
- Begin DoDot:2
- +33 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDPO(X))
- IF X'=+X
- QUIT
- Begin DoDot:3
- +34 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDMC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDMC(BGPPC,19),U,6),BGPPC,X)=$PIECE($GET(BGPSDPO(X,1)),U,2)_U_$PIECE($GET(BGPSDPO(X,2)),U,2)_U_$PIECE($GET(
- BGPSDPO(X,3)),U,2)_U_BGPCYN
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +35 IF BGPROT="D"!(BGPROT="B")
- DO SETSUM^BGP6DP2
- +36 SET X=$$LABEL^BGP6UTL1(BGPPC,BGPRTYPE,BGPPTYPE,$GET(BGPINDM),"N")
- DO S(X,1,1)
- +37 DO H2
- +38 QUIT
- H2 ;
- +1 SET BGPX=""
- SET BGPX=BGPCYN
- SET $PIECE(BGPX,U,2)=$SELECT(BGPCYP]"":$$SB($JUSTIFY(BGPCYP,5,1)),1:"")
- SET $PIECE(BGPX,U,3)=BGPPRN
- SET $PIECE(BGPX,U,4)=$SELECT(BGPPRP]"":$$SB($JUSTIFY(BGPPRP,5,1)),1:"")
- +2 SET $PIECE(BGPX,U,5)=$$SB($JUSTIFY($$CALC(BGPCYN,BGPPRN),6))
- SET $PIECE(BGPX,U,6)=BGPBLN
- SET $PIECE(BGPX,U,7)=$SELECT(BGPBLP]"":$$SB($JUSTIFY(BGPBLP,5,1)),1:"")
- +3 SET $PIECE(BGPX,U,8)=$$SB($JUSTIFY($$CALC(BGPCYN,BGPBLN),6))
- +4 DO S(BGPX,,2)
- +5 QUIT
- H1 ;EP
- +1 SET Y="REPORT"
- DO S(Y,1,2)
- +2 SET Y=" "
- DO S(Y,,3)
- +3 SET Y="PREV YR"
- DO S(Y,,4)
- +4 SET Y=" "
- DO S(Y,,5)
- +5 SET Y="CHG from"
- DO S(Y,,6)
- +6 SET Y="BASE"
- DO S(Y,,7)
- +7 SET Y=" "
- DO S(Y,,8)
- +8 SET Y="CHG from"
- DO S(Y,,9)
- +9 SET Y="PERIOD"
- DO S(Y,1,2)
- +10 SET Y="PERIOD"
- DO S(Y,,4)
- +11 SET Y="PREV YR "
- DO S(Y,,6)
- +12 SET Y="PERIOD"
- DO S(Y,,7)
- +13 SET Y="BASE "
- DO S(Y,,9)
- +14 QUIT
- C(X,X2,X3) ;
- +1 DO COMMA^%DTC
- +2 QUIT X
- S(Y,F,P) ;set up array
- +1 IF '$GET(F)
- SET F=0
- +2 SET %=$PIECE(^TMP($JOB,"BGPDEL",0),U)+F
- SET $PIECE(^TMP($JOB,"BGPDEL",0),U)=%
- +3 IF '$DATA(^TMP($JOB,"BGPDEL",%))
- SET ^TMP($JOB,"BGPDEL",%)=""
- +4 SET $PIECE(^TMP($JOB,"BGPDEL",%),U,P)=Y
- +5 QUIT
- CALC(N,O) ;ENTRY POINT
- +1 NEW Z
- +2 SET Z=N-O
- SET Z=$FNUMBER(Z,"+,",0)
- +3 QUIT Z
- SB(X) ;EP - Strip leading and trailing blanks from X.
- +1 XECUTE ^DD("FUNC",$ORDER(^DD("FUNC","B","STRIPBLANKS",0)),1)
- +2 QUIT X
- SETN ;set numerator fields
- +1 SET BGPIIDEL=1
- SET BGPNOSUM=1
- +2 DO SETN^BGP6DP1C
- +3 KILL BGPNOSUM,BGPIIDEL
- +4 SET (BGPCYP,BGPPRP,BGPBLP)=""
- +5 QUIT
