- BGP9PDL2 ; IHS/CMI/LAB - print ind 1 ;
- ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
- ;
- ;
- ;this routine for Measure I14 ONLY
- I10 ;EP
- S BGPORXX=$P(^BGPINDN(BGPIC,0),U,6)
- D H1 S BGPNODEN=1
- F BGPPC1="10.1","10.2" D PI
- Q
- I11 ;EP
- S BGPORXX=$P(^BGPINDN(BGPIC,0),U,6)
- D H1 S BGPNODEN=1
- F BGPPC1="11.1","11.2","11.3" D PI
- Q
- ISTI ;EP
- S BGPORXX=$P(^BGPINDN(BGPIC,0),U,6)
- D H1 S BGPNODEN=1
- F BGPPC1=BGPORXX_".1",BGPORXX_".2",BGPORXX_".3" D PI
- S BGPNODEN=1
- F BGPPC1=BGPORXX_".4",BGPORXX_".5",BGPORXX_".6" D PI ;
- ;
- K BGPNODEN
- F BGPPC1=BGPORXX_".7",BGPORXX_".8",BGPORXX_".9" D PI^BGP9PDL1 ;
- ;
- F BGPPC1=BGPORXX_".10",BGPORXX_".11",BGPORXX_".12" D PI^BGP9PDL1 ;
- ;
- F BGPPC1=BGPORXX_".13",BGPORXX_".14",BGPORXX_".15" D PI^BGP9PDL1 ;
- ;
- F BGPPC1=BGPORXX_".16",BGPORXX_".17",BGPORXX_".18" D PI^BGP9PDL1 ;
- ;
- F BGPPC1=BGPORXX_".19",BGPORXX_".20",BGPORXX_".21" D PI^BGP9PDL1 ;
- ;
- ;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^BGP9PDL1 ;
- ;
- F BGPPC1=BGPORXX_".31",BGPORXX_".32",BGPORXX_".33" D PI^BGP9PDL1 ;
- ;
- F BGPPC1=BGPORXX_".34",BGPORXX_".35",BGPORXX_".36" D PI^BGP9PDL1 ;
- ;
- F BGPPC1=BGPORXX_".37",BGPORXX_".38",BGPORXX_".39" D PI^BGP9PDL1 ;
- ;
- F BGPPC1=BGPORXX_".40",BGPORXX_".41",BGPORXX_".42" D PI^BGP9PDL1 ;
- ;
- Q
- IPC ;EP
- S BGPORXX=$P(^BGPINDN(BGPIC,0),U,6)
- D 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 ;
- Q
- PI ;EP
- S BGPDENP=0
- K BGPDHOLD
- K BGPCYP,BGPBLP,BGPPRP
- S BGPPC2=0 F S BGPPC2=$O(^BGPINDNC("AB",BGPPC1,BGPPC2)) Q:BGPPC2="" S BGPPC=$O(^BGPINDNC("AB",BGPPC1,BGPPC2,0)) D PI1
- Q
- PI1 ;EP
- K BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
- I BGPRTYPE=1,$P(^BGPINDNC(BGPPC,0),U,5)'=1 Q ;not on national
- I BGPRTYPE=7,$P($G(^BGPINDNC(BGPPC,12)),U,12)'=1 Q ;not on other national
- I BGPINDT="D",$P(^BGPINDNC(BGPPC,0),U,12)'=1 Q
- I BGPINDT="C",$P(^BGPINDNC(BGPPC,0),U,13)'=1 Q
- I BGPINDT="W",$P($G(^BGPINDNC(BGPPC,12)),U,2)'=1 Q
- I BGPINDT="E",$P($G(^BGPINDNC(BGPPC,12)),U,3)'=1 Q
- ;get numerator value of measure and calc %
- S BGPDF=$P(^BGPINDNC(BGPPC,0),U,9)
- ;I $P(^BGPINDNC(BGPPC,0),U,4)[".1" S BGPDHOLD=BGPDF
- ;I $P(^BGPINDNC(BGPPC,0),U,4)'[".1" S BGPDF=BGPDHOLD
- S BGPNP=$P(^DD(90536.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- S BGPCYD=$$V^BGP9DP1C(1,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP9DP1C(1,N,P)
- S BGPPRD=$$V^BGP9DP1C(2,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP9DP1C(2,N,P)
- S BGPBLD=$$V^BGP9DP1C(3,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP9DP1C(3,N,P)
- S BGPNF=$P(^BGPINDNC(BGPPC,0),U,9)
- S BGPNP=$P(^DD(90536.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- D SETN
- I $P($G(^BGPINDNC(BGPPC,14)),U) D
- .S ^TMP($J,"SUMMARYDEL",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,14),U,5),0),U,2),$P(^BGPINDNC(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(^BGPINDNC(BGPPC,14),U,5),0),U,2),$P(^BGPINDNC(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(^BGPINDNC(BGPPC,15)),U) D
- .S ^TMP($J,"SUMMARYDEL NON",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,15),U,5),0),U,3),$P(^BGPINDNC(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(^BGPINDNC(BGPPC,15),U,5),0),U,3),$P(^BGPINDNC(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(^BGPINDNC(BGPPC,22)),U) D
- .S ^TMP($J,"SUMMARYDEL DEVEL",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,22),U,5),0),U,3),$P(^BGPINDNC(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(^BGPINDNC(BGPPC,22),U,5),0),U,3),$P(^BGPINDNC(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(^BGPINDNC(BGPPC,19)),U) D
- .S ^TMP($J,"SUMMARYDEL OTHER",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,19),U,5),0),U,3),$P(^BGPINDNC(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(^BGPINDNC(BGPPC,19),U,5),0),U,3),$P(^BGPINDNC(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
- ;write header for 1.A.1
- ;S X=$P(^BGPINDNC(BGPPC,0),U,15) D S(X,1,1)
- ;I $P(^BGPINDNC(BGPPC,0),U,16)]"" S X=$P(^BGPINDNC(BGPPC,0),U,16) D S(X,1,1)
- ;I $P(^BGPINDNC(BGPPC,0),U,19)]"" S Y=$P(^BGPINDNC(BGPPC,0),U,19) D S(Y,1,1)
- S X=$P(^BGPINDNC(BGPPC,0),U,15)_" "_$P(^BGPINDNC(BGPPC,0),U,16)_" "_$P(^BGPINDNC(BGPPC,0),U,19) 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^BGP9DP1C
- ;I $P(^BGPINDNC(BGPPC,0),U,4)[".1"
- K BGPNOSUM,BGPIIDEL
- S (BGPCYP,BGPPRP,BGPBLP)=""
- Q
- BGP9PDL2 ; IHS/CMI/LAB - print ind 1 ;
- +1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
- +2 ;
- +3 ;
- +4 ;this routine for Measure I14 ONLY
- I10 ;EP
- +1 SET BGPORXX=$PIECE(^BGPINDN(BGPIC,0),U,6)
- +2 DO H1
- SET BGPNODEN=1
- +3 FOR BGPPC1="10.1","10.2"
- DO PI
- +4 QUIT
- I11 ;EP
- +1 SET BGPORXX=$PIECE(^BGPINDN(BGPIC,0),U,6)
- +2 DO H1
- SET BGPNODEN=1
- +3 FOR BGPPC1="11.1","11.2","11.3"
- DO PI
- +4 QUIT
- ISTI ;EP
- +1 SET BGPORXX=$PIECE(^BGPINDN(BGPIC,0),U,6)
- +2 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",BGPORXX_".5",BGPORXX_".6"
- DO PI
- +6 ;
- +7 KILL BGPNODEN
- +8 ;
- FOR BGPPC1=BGPORXX_".7",BGPORXX_".8",BGPORXX_".9"
- DO PI^BGP9PDL1
- +9 ;
- +10 ;
- FOR BGPPC1=BGPORXX_".10",BGPORXX_".11",BGPORXX_".12"
- DO PI^BGP9PDL1
- +11 ;
- +12 ;
- FOR BGPPC1=BGPORXX_".13",BGPORXX_".14",BGPORXX_".15"
- DO PI^BGP9PDL1
- +13 ;
- +14 ;
- FOR BGPPC1=BGPORXX_".16",BGPORXX_".17",BGPORXX_".18"
- DO PI^BGP9PDL1
- +15 ;
- +16 ;
- FOR BGPPC1=BGPORXX_".19",BGPORXX_".20",BGPORXX_".21"
- DO PI^BGP9PDL1
- +17 ;
- +18 ;USER POP
- +19 DO S(" ",1,1)
- +20 SET BGPNODEN=1
- +21 ;
- FOR BGPPC1=BGPORXX_".22",BGPORXX_".23",BGPORXX_".24"
- DO PI
- +22 ;
- +23 SET BGPNODEN=1
- +24 ;
- FOR BGPPC1=BGPORXX_".25",BGPORXX_".26",BGPORXX_".27"
- DO PI
- +25 KILL BGPNODEN
- +26 ;
- FOR BGPPC1=BGPORXX_".28",BGPORXX_".29",BGPORXX_".30"
- DO PI^BGP9PDL1
- +27 ;
- +28 ;
- FOR BGPPC1=BGPORXX_".31",BGPORXX_".32",BGPORXX_".33"
- DO PI^BGP9PDL1
- +29 ;
- +30 ;
- FOR BGPPC1=BGPORXX_".34",BGPORXX_".35",BGPORXX_".36"
- DO PI^BGP9PDL1
- +31 ;
- +32 ;
- FOR BGPPC1=BGPORXX_".37",BGPORXX_".38",BGPORXX_".39"
- DO PI^BGP9PDL1
- +33 ;
- +34 ;
- FOR BGPPC1=BGPORXX_".40",BGPORXX_".41",BGPORXX_".42"
- DO PI^BGP9PDL1
- +35 ;
- +36 QUIT
- IPC ;EP
- +1 SET BGPORXX=$PIECE(^BGPINDN(BGPIC,0),U,6)
- +2 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 QUIT
- PI ;EP
- +1 SET BGPDENP=0
- +2 KILL BGPDHOLD
- +3 KILL BGPCYP,BGPBLP,BGPPRP
- +4 SET BGPPC2=0
- FOR
- SET BGPPC2=$ORDER(^BGPINDNC("AB",BGPPC1,BGPPC2))
- IF BGPPC2=""
- QUIT
- SET BGPPC=$ORDER(^BGPINDNC("AB",BGPPC1,BGPPC2,0))
- DO PI1
- +5 QUIT
- PI1 ;EP
- +1 KILL BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
- +2 ;not on national
- IF BGPRTYPE=1
- IF $PIECE(^BGPINDNC(BGPPC,0),U,5)'=1
- QUIT
- +3 ;not on other national
- IF BGPRTYPE=7
- IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,12)'=1
- QUIT
- +4 IF BGPINDT="D"
- IF $PIECE(^BGPINDNC(BGPPC,0),U,12)'=1
- QUIT
- +5 IF BGPINDT="C"
- IF $PIECE(^BGPINDNC(BGPPC,0),U,13)'=1
- QUIT
- +6 IF BGPINDT="W"
- IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,2)'=1
- QUIT
- +7 IF BGPINDT="E"
- IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,3)'=1
- QUIT
- +8 ;get numerator value of measure and calc %
- +9 SET BGPDF=$PIECE(^BGPINDNC(BGPPC,0),U,9)
- +10 ;I $P(^BGPINDNC(BGPPC,0),U,4)[".1" S BGPDHOLD=BGPDF
- +11 ;I $P(^BGPINDNC(BGPPC,0),U,4)'[".1" S BGPDF=BGPDHOLD
- +12 SET BGPNP=$PIECE(^DD(90536.03,BGPDF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +13 SET BGPCYD=$$V^BGP9DP1C(1,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP9DP1C(1,N,P)
- +14 SET BGPPRD=$$V^BGP9DP1C(2,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP9DP1C(2,N,P)
- +15 SET BGPBLD=$$V^BGP9DP1C(3,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP9DP1C(3,N,P)
- +16 SET BGPNF=$PIECE(^BGPINDNC(BGPPC,0),U,9)
- +17 SET BGPNP=$PIECE(^DD(90536.03,BGPNF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +18 DO SETN
- +19 IF $PIECE($GET(^BGPINDNC(BGPPC,14)),U)
- Begin DoDot:1
- +20 SET ^TMP($JOB,"SUMMARYDEL",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDNC(BGPPC,14),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +21 IF '$GET(BGPAREAA)
- QUIT
- +22 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDP(X))
- IF X'=+X
- QUIT
- Begin DoDot:2
- +23 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDNC(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
- +24 ;NON
- +25 IF $PIECE($GET(^BGPINDNC(BGPPC,15)),U)
- Begin DoDot:1
- +26 SET ^TMP($JOB,"SUMMARYDEL NON",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,15),U,5),0),U,3),$PIECE(^BGPINDNC(BGPPC,15),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +27 ;SDPX
- IF $GET(BGPAREAA)
- Begin DoDot:2
- +28 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDPN(X))
- IF X'=+X
- QUIT
- Begin DoDot:3
- +29 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE NON",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,15),U,5),0),U,3),$PIECE(^BGPINDNC(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
- +30 ;DEVEL
- +31 IF $PIECE($GET(^BGPINDNC(BGPPC,22)),U)
- Begin DoDot:1
- +32 SET ^TMP($JOB,"SUMMARYDEL DEVEL",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,22),U,5),0),U,3),$PIECE(^BGPINDNC(BGPPC,22),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +33 ;SDPX
- IF $GET(BGPAREAA)
- Begin DoDot:2
- +34 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDPD(X))
- IF X'=+X
- QUIT
- Begin DoDot:3
- +35 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE DEVEL",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,22),U,5),0),U,3),$PIECE(^BGPINDNC(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
- +36 ;OTHER
- +37 IF $PIECE($GET(^BGPINDNC(BGPPC,19)),U)
- Begin DoDot:1
- +38 SET ^TMP($JOB,"SUMMARYDEL OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDNC(BGPPC,19),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +39 ;SDPX
- IF $GET(BGPAREAA)
- Begin DoDot:2
- +40 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDPO(X))
- IF X'=+X
- QUIT
- Begin DoDot:3
- +41 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDNC(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
- +42 ;write header for 1.A.1
- +43 ;S X=$P(^BGPINDNC(BGPPC,0),U,15) D S(X,1,1)
- +44 ;I $P(^BGPINDNC(BGPPC,0),U,16)]"" S X=$P(^BGPINDNC(BGPPC,0),U,16) D S(X,1,1)
- +45 ;I $P(^BGPINDNC(BGPPC,0),U,19)]"" S Y=$P(^BGPINDNC(BGPPC,0),U,19) D S(Y,1,1)
- +46 SET X=$PIECE(^BGPINDNC(BGPPC,0),U,15)_" "_$PIECE(^BGPINDNC(BGPPC,0),U,16)_" "_$PIECE(^BGPINDNC(BGPPC,0),U,19)
- DO S(X,1,1)
- +47 DO H2
- +48 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^BGP9DP1C
- +3 ;I $P(^BGPINDNC(BGPPC,0),U,4)[".1"
- +4 KILL BGPNOSUM,BGPIIDEL
- +5 SET (BGPCYP,BGPPRP,BGPBLP)=""
- +6 QUIT
