- BGP8DP3 ; IHS/CMI/LAB - print ind 1 ;
- ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
- ;
- ;PUBLIC HEALTH NURSING
- I023 ;EP
- S BGPORXX=$P(^BGPINDR(BGPIC,12),U,6)
- D H1 S BGPNODEN=1
- F BGPPC1=BGPORXX_".1" D PI^BGP8DP1C Q:BGPQUIT
- Q:BGPQUIT
- F BGPPC1=BGPORXX_".2.1",BGPORXX_".2.2",BGPORXX_".2.3",BGPORXX_".2.4",BGPORXX_".2.5",BGPORXX_".2.6" Q:BGPQUIT D PI
- Q:BGPQUIT
- W:'$G(BGPSUMON) ! F BGPPC1=BGPORXX_".3.1",BGPORXX_".3.2",BGPORXX_".3.3",BGPORXX_".3.4",BGPORXX_".3.5",BGPORXX_".3.6" Q:BGPQUIT D PI
- Q
- PI ;EP
- K BGPCYP,BGPBLP,BGPPRD,BGPEXCT,BGPSDP,BGPSDPN,BGPSDPD
- S BGPPC=$O(^BGPINDRC("OR",BGPPC1,0))
- Q:'$$CHECK^BGP8DP1E(BGPPC)
- S BGPPC=BGPPC D
- .S BGPDF=$P(^BGPINDRC(BGPPC,0),U,9)
- .;I $P(^BGPINDRC(BGPPC,0),U,4)[".3" S BGPDF=23.503
- .;I $P(^BGPINDRC(BGPPC,0),U,4)[".4" S BGPDF=23.504
- .S BGPNP=$P(^DD(90560.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- .S BGPCYD=$$V^BGP8DP1C(1,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP8DP1C(1,N,P)
- .S BGPPRD=$$V^BGP8DP1C(2,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP8DP1C(2,N,P)
- .S BGPBLD=$$V^BGP8DP1C(3,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP8DP1C(3,N,P)
- .S BGPNF=$P(^BGPINDRC(BGPPC,0),U,9)
- .S BGPNP=$P(^DD(90560.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- .D SETN
- .I $P($G(^BGPINDRC(BGPPC,14)),U) D
- ..S ^TMP($J,"SUMMARY",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,14),U,5),0),U,2),$P(^BGPINDRC(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,"SUMMARY DETAIL PAGE",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,14),U,5),0),U,2),$P(^BGPINDRC(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(^BGPINDRC(BGPPC,15)),U) D
- ..S ^TMP($J,"SUMMARY NON",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,15),U,5),0),U,3),$P(^BGPINDRC(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,"SUMMARY DETAIL PAGE NON",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,15),U,5),0),U,3),$P(^BGPINDRC(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(^BGPINDRC(BGPPC,22)),U) D
- ..S ^TMP($J,"SUMMARY DEVEL",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,22),U,5),0),U,3),$P(^BGPINDRC(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,"SUMMARY DETAIL PAGE DEVEL",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,22),U,5),0),U,3),$P(^BGPINDRC(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(^BGPINDRC(BGPPC,19)),U) D
- ..S ^TMP($J,"SUMMARY OTHER",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,19),U,5),0),U,3),$P(^BGPINDRC(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,"SUMMARY DETAIL PAGE OTHER",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,19),U,5),0),U,3),$P(^BGPINDRC(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
- .I $Y>(BGPIOSL-6),'$G(BGPSUMON) D HEADER^BGP8DPH Q:BGPQUIT W !!,^BGPINDR(BGPIC,53,1,0) W:$D(^BGPINDR(BGPIC,53,2,0)) !,^BGPINDR(BGPIC,53,2,0) D H1
- .;I BGPRTYPE'=1 W !!,$P(^BGPINDRC(BGPPC,0),U,15)
- .;I BGPRTYPE=1 W !!
- .I '$G(BGPSUMON) D
- ..S X=$$LABEL^BGP8UTL1(BGPPC,BGPRTYPE,BGPPTYPE,$G(BGPINDG),"N")
- ..W !,$P(X,U,1)
- ..F I=2:1 S Y=$P(X,U,I) Q:Y="" W !," ",Y
- .D H2
- Q
- H2 ;EP
- Q:$G(BGPSUMON)
- S BGPX="",BGPX=$$C(BGPCYN,0,7),$E(BGPX,16)=$$C(BGPPRN,0,7),$E(BGPX,24)="",$E(BGPX,33)=$$CALC(BGPCYN,BGPPRN)
- S $E(BGPX,39)=$$C(BGPBLN,0,7),$E(BGPX,47)="",$E(BGPX,56)=$$CALC(BGPCYN,BGPBLN)
- W ?21,BGPX
- Q
- H1 ;EP
- Q:$G(BGPSUMON)
- W !!?21,"REPORT",?31,"",?35,"PREV YR",?46,"",?49,"CHG from",?59,"BASE",?69,"",?72,"CHG from"
- W !?21,"PERIOD %",?35,"PERIOD %",?49,"PREV YR ",?59,"PERIOD %",?72,"BASE "
- Q
- CALC(N,O) ;ENTRY POINT
- NEW Z
- S Z=N-O,Z=$FN(Z,"+,",0)
- Q Z
- C(X,X2,X3) ;
- D COMMA^%DTC
- Q X
- SETN ;set numerator fields
- S BGPNOSUM=1
- D SETN^BGP8DP1C
- ;I $P(^BGPINDRC(BGPPC,0),U,4)[".1"
- K BGPNOSUM
- S (BGPCYP,BGPPRP,BGPBLP)=""
- Q
- BGP8DP3 ; IHS/CMI/LAB - print ind 1 ;
- +1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
- +2 ;
- +3 ;PUBLIC HEALTH NURSING
- I023 ;EP
- +1 SET BGPORXX=$PIECE(^BGPINDR(BGPIC,12),U,6)
- +2 DO H1
- SET BGPNODEN=1
- +3 FOR BGPPC1=BGPORXX_".1"
- DO PI^BGP8DP1C
- IF BGPQUIT
- QUIT
- +4 IF BGPQUIT
- QUIT
- +5 FOR BGPPC1=BGPORXX_".2.1",BGPORXX_".2.2",BGPORXX_".2.3",BGPORXX_".2.4",BGPORXX_".2.5",BGPORXX_".2.6"
- IF BGPQUIT
- QUIT
- DO PI
- +6 IF BGPQUIT
- QUIT
- +7 IF '$GET(BGPSUMON)
- WRITE !
- FOR BGPPC1=BGPORXX_".3.1",BGPORXX_".3.2",BGPORXX_".3.3",BGPORXX_".3.4",BGPORXX_".3.5",BGPORXX_".3.6"
- IF BGPQUIT
- QUIT
- DO PI
- +8 QUIT
- PI ;EP
- +1 KILL BGPCYP,BGPBLP,BGPPRD,BGPEXCT,BGPSDP,BGPSDPN,BGPSDPD
- +2 SET BGPPC=$ORDER(^BGPINDRC("OR",BGPPC1,0))
- +3 IF '$$CHECK^BGP8DP1E(BGPPC)
- QUIT
- +4 SET BGPPC=BGPPC
- Begin DoDot:1
- +5 SET BGPDF=$PIECE(^BGPINDRC(BGPPC,0),U,9)
- +6 ;I $P(^BGPINDRC(BGPPC,0),U,4)[".3" S BGPDF=23.503
- +7 ;I $P(^BGPINDRC(BGPPC,0),U,4)[".4" S BGPDF=23.504
- +8 SET BGPNP=$PIECE(^DD(90560.03,BGPDF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +9 SET BGPCYD=$$V^BGP8DP1C(1,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP8DP1C(1,N,P)
- +10 SET BGPPRD=$$V^BGP8DP1C(2,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP8DP1C(2,N,P)
- +11 SET BGPBLD=$$V^BGP8DP1C(3,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP8DP1C(3,N,P)
- +12 SET BGPNF=$PIECE(^BGPINDRC(BGPPC,0),U,9)
- +13 SET BGPNP=$PIECE(^DD(90560.03,BGPNF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +14 DO SETN
- +15 IF $PIECE($GET(^BGPINDRC(BGPPC,14)),U)
- Begin DoDot:2
- +16 SET ^TMP($JOB,"SUMMARY",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDRC(BGPPC,14),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +17 IF '$GET(BGPAREAA)
- QUIT
- +18 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDP(X))
- IF X'=+X
- QUIT
- Begin DoDot:3
- +19 SET ^TMP($JOB,"SUMMARY DETAIL PAGE",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDRC(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:3
- End DoDot:2
- +20 ;NON
- +21 IF $PIECE($GET(^BGPINDRC(BGPPC,15)),U)
- Begin DoDot:2
- +22 SET ^TMP($JOB,"SUMMARY NON",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,15),U,5),0),U,3),$PIECE(^BGPINDRC(BGPPC,15),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +23 ;SDPX
- IF $GET(BGPAREAA)
- Begin DoDot:3
- +24 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDPN(X))
- IF X'=+X
- QUIT
- Begin DoDot:4
- +25 SET ^TMP($JOB,"SUMMARY DETAIL PAGE NON",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,15),U,5),0),U,3),$PIECE(^BGPINDRC(BGPPC,15),U,6),BGPPC,X)=$PIECE($GET(BGPSDPN(X,1)),U,2)_U_$PIECE($GET(BGPSDPN(X,2)),U,2)_U_$PIECE($GET(B
- GPSDPN(X,3)),U,2)_U_BGPCYN
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +26 ;DEVEL
- +27 IF $PIECE($GET(^BGPINDRC(BGPPC,22)),U)
- Begin DoDot:2
- +28 SET ^TMP($JOB,"SUMMARY DEVEL",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,22),U,5),0),U,3),$PIECE(^BGPINDRC(BGPPC,22),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +29 ;SDPX
- IF $GET(BGPAREAA)
- Begin DoDot:3
- +30 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDPD(X))
- IF X'=+X
- QUIT
- Begin DoDot:4
- +31 SET ^TMP($JOB,"SUMMARY DETAIL PAGE DEVEL",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,22),U,5),0),U,3),$PIECE(^BGPINDRC(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:4
- End DoDot:3
- End DoDot:2
- +32 ;OTHER
- +33 IF $PIECE($GET(^BGPINDRC(BGPPC,19)),U)
- Begin DoDot:2
- +34 SET ^TMP($JOB,"SUMMARY OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDRC(BGPPC,19),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +35 ;SDPX
- IF $GET(BGPAREAA)
- Begin DoDot:3
- +36 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDPO(X))
- IF X'=+X
- QUIT
- Begin DoDot:4
- +37 SET ^TMP($JOB,"SUMMARY DETAIL PAGE OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDRC(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:4
- End DoDot:3
- End DoDot:2
- +38 ;write header for 1.A.1
- +39 IF $Y>(BGPIOSL-6)
- IF '$GET(BGPSUMON)
- DO HEADER^BGP8DPH
- IF BGPQUIT
- QUIT
- WRITE !!,^BGPINDR(BGPIC,53,1,0)
- IF $DATA(^BGPINDR(BGPIC,53,2,0))
- WRITE !,^BGPINDR(BGPIC,53,2,0)
- DO H1
- +40 ;I BGPRTYPE'=1 W !!,$P(^BGPINDRC(BGPPC,0),U,15)
- +41 ;I BGPRTYPE=1 W !!
- +42 IF '$GET(BGPSUMON)
- Begin DoDot:2
- +43 SET X=$$LABEL^BGP8UTL1(BGPPC,BGPRTYPE,BGPPTYPE,$GET(BGPINDG),"N")
- +44 WRITE !,$PIECE(X,U,1)
- +45 FOR I=2:1
- SET Y=$PIECE(X,U,I)
- IF Y=""
- QUIT
- WRITE !," ",Y
- End DoDot:2
- +46 DO H2
- End DoDot:1
- +47 QUIT
- H2 ;EP
- +1 IF $GET(BGPSUMON)
- QUIT
- +2 SET BGPX=""
- SET BGPX=$$C(BGPCYN,0,7)
- SET $EXTRACT(BGPX,16)=$$C(BGPPRN,0,7)
- SET $EXTRACT(BGPX,24)=""
- SET $EXTRACT(BGPX,33)=$$CALC(BGPCYN,BGPPRN)
- +3 SET $EXTRACT(BGPX,39)=$$C(BGPBLN,0,7)
- SET $EXTRACT(BGPX,47)=""
- SET $EXTRACT(BGPX,56)=$$CALC(BGPCYN,BGPBLN)
- +4 WRITE ?21,BGPX
- +5 QUIT
- H1 ;EP
- +1 IF $GET(BGPSUMON)
- QUIT
- +2 WRITE !!?21,"REPORT",?31,"",?35,"PREV YR",?46,"",?49,"CHG from",?59,"BASE",?69,"",?72,"CHG from"
- +3 WRITE !?21,"PERIOD %",?35,"PERIOD %",?49,"PREV YR ",?59,"PERIOD %",?72,"BASE "
- +4 QUIT
- CALC(N,O) ;ENTRY POINT
- +1 NEW Z
- +2 SET Z=N-O
- SET Z=$FNUMBER(Z,"+,",0)
- +3 QUIT Z
- C(X,X2,X3) ;
- +1 DO COMMA^%DTC
- +2 QUIT X
- SETN ;set numerator fields
- +1 SET BGPNOSUM=1
- +2 DO SETN^BGP8DP1C
- +3 ;I $P(^BGPINDRC(BGPPC,0),U,4)[".1"
- +4 KILL BGPNOSUM
- +5 SET (BGPCYP,BGPPRP,BGPBLP)=""
- +6 QUIT