BGPAP221 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
;
;
POV ;
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
BGPAP221 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
+1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
+2 ;
+3 ;
POV ;
+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
