- BGPDP221 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
- ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
- ;
- ;
- POV ;EP
- I $G(BGPAREAA),'$G(BGPSUMR) G AREAPOV
- K ^TMP($J,"PHN")
- S BGPX=0 F S BGPX=$O(^BGPD(BGPRPT,180,BGPX)) Q:BGPX'=+BGPX D
- .S BGPY=^BGPD(BGPRPT,180,BGPX,0)
- .S C=$P(BGPY,U),HV=$P(BGPY,U,3),V=$P(BGPY,U,2)
- .I V S ^TMP($J,"PHN","ALLV","CY",9999999-V,C)=""
- .I HV S ^TMP($J,"PHN","HOME","CY",9999999-HV,C)=""
- S BGPX=0 F S BGPX=$O(^BGPD(BGPRPT,480,BGPX)) Q:BGPX'=+BGPX D
- .S BGPY=^BGPD(BGPRPT,480,BGPX,0)
- .S C=$P(BGPY,U),HV=$P(BGPY,U,3),V=$P(BGPY,U,2)
- .I V S ^TMP($J,"PHN","ALLV","PR",9999999-V,C)=""
- .I HV S ^TMP($J,"PHN","HOME","PR",9999999-HV,C)=""
- S BGPX=0 F S BGPX=$O(^BGPD(BGPRPT,880,BGPX)) Q:BGPX'=+BGPX D
- .S BGPY=^BGPD(BGPRPT,880,BGPX,0)
- .S C=$P(BGPY,U),HV=$P(BGPY,U,3),V=$P(BGPY,U,2)
- .I V S ^TMP($J,"PHN","ALLV","BL",9999999-V,C)=""
- .I HV S ^TMP($J,"PHN","HOME","BL",9999999-HV,C)=""
- Q
- AREAPOV ;
- K ^TMP($J,"PHN")
- S BGPRPT=0 F S BGPRPT=$O(BGPSUL(BGPRPT)) Q:BGPRPT'=+BGPRPT D
- .S BGPX=0 F S BGPX=$O(^BGPD(BGPRPT,180,BGPX)) Q:BGPX'=+BGPX D
- ..S BGPY=^BGPD(BGPRPT,180,BGPX,0)
- ..S C=$P(BGPY,U),HV=$P(BGPY,U,3),V=$P(BGPY,U,2)
- ..I V S ^TMP($J,"PHN","ALLVT","CY",C)=$G(^TMP($J,"PHN","ALLVT","CY",C))+V
- ..I HV S ^TMP($J,"PHN","HOMET","CY",C)=$G(^TMP($J,"PHN","HOMET","CY",C))+HV
- .S BGPX=0 F S BGPX=$O(^BGPD(BGPRPT,480,BGPX)) Q:BGPX'=+BGPX D
- ..S BGPY=^BGPD(BGPRPT,480,BGPX,0)
- ..S C=$P(BGPY,U),HV=$P(BGPY,U,3),V=$P(BGPY,U,2)
- ..I V S ^TMP($J,"PHN","ALLVT","PR",C)=$G(^TMP($J,"PHN","ALLVT","PR",C))+V
- ..I HV S ^TMP($J,"PHN","HOMET","PR",C)=$G(^TMP($J,"PHN","HOMET","PR",C))+HV
- .S BGPX=0 F S BGPX=$O(^BGPD(BGPRPT,880,BGPX)) Q:BGPX'=+BGPX D
- ..S BGPY=^BGPD(BGPRPT,880,BGPX,0)
- ..S C=$P(BGPY,U),HV=$P(BGPY,U,3),V=$P(BGPY,U,2)
- ..I V S ^TMP($J,"PHN","ALLVT","BL",C)=$G(^TMP($J,"PHN","ALLVT","BL",C))+V
- ..I HV S ^TMP($J,"PHN","HOMET","BL",C)=$G(^TMP($J,"PHN","HOMET","BL",C))+HV
- S X="" F S X=$O(^TMP($J,"PHN","ALLVT","CY",X)) Q:X="" S Y=^TMP($J,"PHN","ALLVT","CY",X),^TMP($J,"PHN","ALLV","CY",9999999-Y,X)=""
- S X="" F S X=$O(^TMP($J,"PHN","ALLVT","PR",X)) Q:X="" S Y=^TMP($J,"PHN","ALLVT","PR",X),^TMP($J,"PHN","ALLV","PR",9999999-Y,X)=""
- S X="" F S X=$O(^TMP($J,"PHN","ALLVT","BL",X)) Q:X="" S Y=^TMP($J,"PHN","ALLVT","BL",X),^TMP($J,"PHN","ALLV","BL",9999999-Y,X)=""
- S X="" F S X=$O(^TMP($J,"PHN","HOMET","CY",X)) Q:X="" S Y=^TMP($J,"PHN","HOMET","CY",X),^TMP($J,"PHN","HOME","CY",9999999-Y,X)=""
- S X="" F S X=$O(^TMP($J,"PHN","HOMET","PR",X)) Q:X="" S Y=^TMP($J,"PHN","HOMET","PR",X),^TMP($J,"PHN","HOME","PR",9999999-Y,X)=""
- S X="" F S X=$O(^TMP($J,"PHN","HOMET","BL",X)) Q:X="" S Y=^TMP($J,"PHN","HOMET","BL",X),^TMP($J,"PHN","HOME","BL",9999999-Y,X)=""
- Q
- BGPDP221 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
- +1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
- +2 ;
- +3 ;
- POV ;EP
- +1 IF $GET(BGPAREAA)
- IF '$GET(BGPSUMR)
- GOTO AREAPOV
- +2 KILL ^TMP($JOB,"PHN")
- +3 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPD(BGPRPT,180,BGPX))
- IF BGPX'=+BGPX
- QUIT
- Begin DoDot:1
- +4 SET BGPY=^BGPD(BGPRPT,180,BGPX,0)
- +5 SET C=$PIECE(BGPY,U)
- SET HV=$PIECE(BGPY,U,3)
- SET V=$PIECE(BGPY,U,2)
- +6 IF V
- SET ^TMP($JOB,"PHN","ALLV","CY",9999999-V,C)=""
- +7 IF HV
- SET ^TMP($JOB,"PHN","HOME","CY",9999999-HV,C)=""
- End DoDot:1
- +8 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPD(BGPRPT,480,BGPX))
- IF BGPX'=+BGPX
- QUIT
- Begin DoDot:1
- +9 SET BGPY=^BGPD(BGPRPT,480,BGPX,0)
- +10 SET C=$PIECE(BGPY,U)
- SET HV=$PIECE(BGPY,U,3)
- SET V=$PIECE(BGPY,U,2)
- +11 IF V
- SET ^TMP($JOB,"PHN","ALLV","PR",9999999-V,C)=""
- +12 IF HV
- SET ^TMP($JOB,"PHN","HOME","PR",9999999-HV,C)=""
- End DoDot:1
- +13 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPD(BGPRPT,880,BGPX))
- IF BGPX'=+BGPX
- QUIT
- Begin DoDot:1
- +14 SET BGPY=^BGPD(BGPRPT,880,BGPX,0)
- +15 SET C=$PIECE(BGPY,U)
- SET HV=$PIECE(BGPY,U,3)
- SET V=$PIECE(BGPY,U,2)
- +16 IF V
- SET ^TMP($JOB,"PHN","ALLV","BL",9999999-V,C)=""
- +17 IF HV
- SET ^TMP($JOB,"PHN","HOME","BL",9999999-HV,C)=""
- End DoDot:1
- +18 QUIT
- AREAPOV ;
- +1 KILL ^TMP($JOB,"PHN")
- +2 SET BGPRPT=0
- FOR
- SET BGPRPT=$ORDER(BGPSUL(BGPRPT))
- IF BGPRPT'=+BGPRPT
- QUIT
- Begin DoDot:1
- +3 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPD(BGPRPT,180,BGPX))
- IF BGPX'=+BGPX
- QUIT
- Begin DoDot:2
- +4 SET BGPY=^BGPD(BGPRPT,180,BGPX,0)
- +5 SET C=$PIECE(BGPY,U)
- SET HV=$PIECE(BGPY,U,3)
- SET V=$PIECE(BGPY,U,2)
- +6 IF V
- SET ^TMP($JOB,"PHN","ALLVT","CY",C)=$GET(^TMP($JOB,"PHN","ALLVT","CY",C))+V
- +7 IF HV
- SET ^TMP($JOB,"PHN","HOMET","CY",C)=$GET(^TMP($JOB,"PHN","HOMET","CY",C))+HV
- End DoDot:2
- +8 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPD(BGPRPT,480,BGPX))
- IF BGPX'=+BGPX
- QUIT
- Begin DoDot:2
- +9 SET BGPY=^BGPD(BGPRPT,480,BGPX,0)
- +10 SET C=$PIECE(BGPY,U)
- SET HV=$PIECE(BGPY,U,3)
- SET V=$PIECE(BGPY,U,2)
- +11 IF V
- SET ^TMP($JOB,"PHN","ALLVT","PR",C)=$GET(^TMP($JOB,"PHN","ALLVT","PR",C))+V
- +12 IF HV
- SET ^TMP($JOB,"PHN","HOMET","PR",C)=$GET(^TMP($JOB,"PHN","HOMET","PR",C))+HV
- End DoDot:2
- +13 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPD(BGPRPT,880,BGPX))
- IF BGPX'=+BGPX
- QUIT
- Begin DoDot:2
- +14 SET BGPY=^BGPD(BGPRPT,880,BGPX,0)
- +15 SET C=$PIECE(BGPY,U)
- SET HV=$PIECE(BGPY,U,3)
- SET V=$PIECE(BGPY,U,2)
- +16 IF V
- SET ^TMP($JOB,"PHN","ALLVT","BL",C)=$GET(^TMP($JOB,"PHN","ALLVT","BL",C))+V
- +17 IF HV
- SET ^TMP($JOB,"PHN","HOMET","BL",C)=$GET(^TMP($JOB,"PHN","HOMET","BL",C))+HV
- End DoDot:2
- End DoDot:1
- +18 SET X=""
- FOR
- SET X=$ORDER(^TMP($JOB,"PHN","ALLVT","CY",X))
- IF X=""
- QUIT
- SET Y=^TMP($JOB,"PHN","ALLVT","CY",X)
- SET ^TMP($JOB,"PHN","ALLV","CY",9999999-Y,X)=""
- +19 SET X=""
- FOR
- SET X=$ORDER(^TMP($JOB,"PHN","ALLVT","PR",X))
- IF X=""
- QUIT
- SET Y=^TMP($JOB,"PHN","ALLVT","PR",X)
- SET ^TMP($JOB,"PHN","ALLV","PR",9999999-Y,X)=""
- +20 SET X=""
- FOR
- SET X=$ORDER(^TMP($JOB,"PHN","ALLVT","BL",X))
- IF X=""
- QUIT
- SET Y=^TMP($JOB,"PHN","ALLVT","BL",X)
- SET ^TMP($JOB,"PHN","ALLV","BL",9999999-Y,X)=""
- +21 SET X=""
- FOR
- SET X=$ORDER(^TMP($JOB,"PHN","HOMET","CY",X))
- IF X=""
- QUIT
- SET Y=^TMP($JOB,"PHN","HOMET","CY",X)
- SET ^TMP($JOB,"PHN","HOME","CY",9999999-Y,X)=""
- +22 SET X=""
- FOR
- SET X=$ORDER(^TMP($JOB,"PHN","HOMET","PR",X))
- IF X=""
- QUIT
- SET Y=^TMP($JOB,"PHN","HOMET","PR",X)
- SET ^TMP($JOB,"PHN","HOME","PR",9999999-Y,X)=""
- +23 SET X=""
- FOR
- SET X=$ORDER(^TMP($JOB,"PHN","HOMET","BL",X))
- IF X=""
- QUIT
- SET Y=^TMP($JOB,"PHN","HOMET","BL",X)
- SET ^TMP($JOB,"PHN","HOME","BL",9999999-Y,X)=""
- +24 QUIT
