BGP0PUTL ; IHS/CMI/LAB - ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
;
;utility calls
;
STMP ;EP
Q:BGPTIME'=1
I BGPLIST="P",$P(^AUPNPAT(DFN,0),U,14)'=BGPLPRV Q
X ^BGPPEIT(BGPIC,2) Q:'$T
S BGPLIST(BGPIC)=$G(BGPLIST(BGPIC))+1
S ^XTMP("BGP0D",BGPJ,BGPH,"LIST",BGPIC,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),BGPAGEB,DFN)=BGPVALUE
Q
D(D) ;EP
I D="" Q ""
Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)_$S($P(D,".",2)]"":$P(D,".",2),1:"")
JRNL ;EP
N (DT,U,ZTQUEUED) S %=$$NOJOURN^ZIBGCHAR("BGPPEDCT"),%=$$NOJOURN^ZIBGCHAR("BGPPEDPT"),%=$$NOJOURN^ZIBGCHAR("BGPPEDBT")
Q
DATE(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
GS ;EP
K ^TMP($J)
I $P($G(^BGPSITE(DUZ(2),0)),U,3)="N" Q
L +^BGPDATA:300 E W:'$D(ZTQUEUED) "Unable to lock global" Q
K ^BGPDATA ;NOTE: Kill of unscripted global. Export to area. Using standard name.
S X="",C=0 F S X=$O(^BGPPEDCT(BGPRPT,X)) Q:X'=+X!(X>99998) D
.I $G(^BGPPEDCT(BGPRPT,X))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",8)=^BGPPEDCT(BGPRPT,X)
.S X2="" F S X2=$O(^BGPPEDCT(BGPRPT,X,X2)) Q:X2'=+X2 D
..I $G(^BGPPEDCT(BGPRPT,X,X2))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",8)=^BGPPEDCT(BGPRPT,X,X2)
..S X3="" F S X3=$O(^BGPPEDCT(BGPRPT,X,X2,X3)) Q:X3'=+X3 D
...I $G(^BGPPEDCT(BGPRPT,X,X2,X3))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3,$P(^BGPDATA(C),"|",8)=^BGPPEDCT(BGPRPT,X,X2,X3)
...S X4="" F S X4=$O(^BGPPEDCT(BGPRPT,X,X2,X3,X4)) Q:X4'=+X4 D
....I $G(^BGPPEDCT(BGPRPT,X,X2,X3,X4))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3,$P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",8)=^BGPPEDCT(BGPRPT,X,X2,X3,X4)
....S X5="" F S X5=$O(^BGPPEDCT(BGPRPT,X,X2,X3,X4,X5)) Q:X5'=+X5 D
.....I $G(^BGPPEDCT(BGPRPT,X,X2,X3,X4,X5))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3
.....S $P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",5)=X5,$P(^BGPDATA(C),"|",8)=^BGPPEDCT(BGPRPT,X,X2,X3,X4,X5)
S X=0 F S X=$O(^BGPDATA(X)) Q:X'=+X S ^BGPDATA(X)="BGPPEDCT"_"|"_^BGPDATA(X)
PRGS ;
S S=C+1,X="" F S X=$O(^BGPPEDPT(BGPRPT,X)) Q:X'=+X!(X>99998) D
.I $G(^BGPPEDPT(BGPRPT,X))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",8)=^BGPPEDPT(BGPRPT,X)
.S X2="" F S X2=$O(^BGPPEDPT(BGPRPT,X,X2)) Q:X2'=+X2 D
..I $G(^BGPPEDPT(BGPRPT,X,X2))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",8)=^BGPPEDPT(BGPRPT,X,X2)
..S X3="" F S X3=$O(^BGPPEDPT(BGPRPT,X,X2,X3)) Q:X3'=+X3 D
...I $G(^BGPPEDPT(BGPRPT,X,X2,X3))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3,$P(^BGPDATA(C),"|",8)=^BGPPEDPT(BGPRPT,X,X2,X3)
...S X4="" F S X4=$O(^BGPPEDPT(BGPRPT,X,X2,X3,X4)) Q:X4'=+X4 D
....I $G(^BGPPEDPT(BGPRPT,X,X2,X3,X4))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3,$P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",8)=^BGPPEDPT(BGPRPT,X,X2,X3,X4)
....S X5="" F S X5=$O(^BGPPEDPT(BGPRPT,X,X2,X3,X4,X5)) Q:X5'=+X5 D
.....I $G(^BGPPEDPT(BGPRPT,X,X2,X3,X4,X5))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3
.....S $P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",5)=X5,$P(^BGPDATA(C),"|",8)=^BGPPEDPT(BGPRPT,X,X2,X3,X4,X5)
S X=S-1 F S X=$O(^BGPDATA(X)) Q:X'=+X S ^BGPDATA(X)="BGPPEDPT"_"|"_^BGPDATA(X)
BLGS ;save off baseline data
S S=C+1,X="" F S X=$O(^BGPPEDBT(BGPRPT,X)) Q:X'=+X!(X>99998) D
.I $G(^BGPPEDBT(BGPRPT,X))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",8)=^BGPPEDBT(BGPRPT,X)
.S X2="" F S X2=$O(^BGPPEDBT(BGPRPT,X,X2)) Q:X2'=+X2 D
..I $G(^BGPPEDBT(BGPRPT,X,X2))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",8)=^BGPPEDBT(BGPRPT,X,X2)
..S X3="" F S X3=$O(^BGPPEDBT(BGPRPT,X,X2,X3)) Q:X3'=+X3 D
...I $G(^BGPPEDBT(BGPRPT,X,X2,X3))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3,$P(^BGPDATA(C),"|",8)=^BGPPEDBT(BGPRPT,X,X2,X3)
...S X4="" F S X4=$O(^BGPPEDBT(BGPRPT,X,X2,X3,X4)) Q:X4'=+X4 D
....I $G(^BGPPEDBT(BGPRPT,X,X2,X3,X4))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3,$P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",8)=^BGPPEDBT(BGPRPT,X,X2,X3,X4)
....S X5="" F S X5=$O(^BGPPEDBT(BGPRPT,X,X2,X3,X4,X5)) Q:X5'=+X5 D
.....I $G(^BGPPEDBT(BGPRPT,X,X2,X3,X4,X5))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3
.....S $P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",5)=X5,$P(^BGPDATA(C),"|",8)=^BGPPEDBT(BGPRPT,X,X2,X3,X4,X5)
S X=S-1 F S X=$O(^BGPDATA(X)) Q:X'=+X S ^BGPDATA(X)="BGPPEDBT"_"|"_^BGPDATA(X)
NEW XBGL S XBGL="BGPDATA"
S F="BG10"_$P(^AUTTLOC(DUZ(2),0),U,10)_".PED"_BGPRPT
NEW XBMED,XBFN,XBTLE,XBF,XBFLT
S XBMED="F",XBFN=F,XBTLE="SAVE OF GPRA DATA BY - "_$P(^VA(200,DUZ,0),U),XBF=0,XBFLT=1
D ^XBGSAVE
L -^BGPDATA
K ^TMP($J),^BGPDATA ;NOTE: kill of unsubscripted global for use in export to area.
Q
REPORT ;EP
S BGPRPT=""
W !!
;CREATE REPORT ENTRY IN FILEMAN FILE
;3 files must have the same ien
L +^BGPPEDCT:30 I '$T W !!,"Unable to lock global, try later." G REPORTX
L +^BGPPEDPT:30 I '$T W !!,"Unable to lock global, try later." G REPORTX
L +^BGPPEDBT:30 I '$T W !!,"Unable to lock global, try later." G REPORTX
D GETIEN
I 'BGPIEN W !!,"Something wrong with control files, notify programmer!" S BGPRPT="" G REPORTX
S DINUM=BGPIEN
K DIC S X=BGPBD,DIC(0)="L",DIC="^BGPPEDCT(",DLAYGO=90377.12,DIADD=1,DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$G(BGPPER)_";.08////"_$G(BGPQTR)
S DIC("DR")=DIC("DR")_";.09////"_$P(^AUTTLOC(DUZ(2),0),U,10)_";.1////"_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.13////"_DT_";.11////"_BGPBEN_";.12////"_$P($G(^AUTTLOC(DUZ(2),1)),U,3)
S DIC("DR")=DIC("DR")_";.17///"_$P(^BGPSITE(DUZ(2),0),U,6)
D ^DIC K DIC,DA,DR,DIADD,DLAYGO I Y=-1 W !!,"UNABLE TO CREATE REPORT FILE ENTRY - NOTIFY SITE MANAGER!" S BGPQUIT=1 G REPORTX
S BGPRPT=+Y
K DIC S X=BGPBD,DIC(0)="L",DIC="^BGPPEDPT(",DLAYGO=90377.13,DIADD=1,DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$G(BGPPER)_";.08////"_$G(BGPQTR)
S DIC("DR")=DIC("DR")_";.09////"_$P(^AUTTLOC(DUZ(2),0),U,10)_";.1////"_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.13////"_DT_";.11////"_BGPBEN_";.12////"_$P($G(^AUTTLOC(DUZ(2),1)),U,3)
S DIC("DR")=DIC("DR")_";.17///"_$P(^BGPSITE(DUZ(2),0),U,6)
S DINUM=BGPRPT D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DINUM I Y=-1 W !!,"UNABLE TO CREATE REPORT FILE ENTRY - NOTIFY SITE MANAGER!" S BGPQUIT=1 G REPORTX
S BGPRPTP=+Y
K DIC S X=BGPBD,DIC(0)="L",DIC="^BGPPEDBT(",DLAYGO=90377.14,DIADD=1,DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$G(BGPPER)_";.08////"_$G(BGPQTR)
S DIC("DR")=DIC("DR")_";.09////"_$P(^AUTTLOC(DUZ(2),0),U,10)_";.1////"_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.13////"_DT_";.11////"_BGPBEN_";.12////"_$P($G(^AUTTLOC(DUZ(2),1)),U,3)
S DIC("DR")=DIC("DR")_";.17///"_$P(^BGPSITE(DUZ(2),0),U,6)
S DINUM=BGPRPT D ^DIC K DIC,DA,DR,DIADD,DLAYGO I Y=-1 W !!,"UNABLE TO CREATE REPORT FILE ENTRY - NOTIFY SITE MANAGER!" S BGPQUIT=1 G REPORTX
S BGPRPTB=+Y
;add communities to 28 multiple
K ^BGPPEDCT(BGPRPT,9999)
S C=0,X="" F S X=$O(BGPTAX(X)) Q:X="" S C=C+1 S ^BGPPEDCT(BGPRPT,9999,C,0)=X,^BGPPEDCT(BGPRPT,9999,"B",X,C)=""
S ^BGPPEDCT(BGPRPT,9999,0)="^90377.12999A^"_C_"^"_C
I $G(BGPMFITI) S C=0,X="" F S X=$O(^ATXAX(BGPMFITI,21,"B",X)) Q:X="" S C=C+1,Y=$P($G(^DIC(4,X,0)),U) S ^BGPPEDCT(BGPRPT,1111,C,0)=Y,^BGPPEDCT(BGPRPT,1111,"B",Y,C)=""
S ^BGPPEDCT(BGPRPT,1111,0)="^90377.12111^"_C_"^"_C
S ^BGPPEDCT(BGPRPT,99999,0)="^90377.12999A^0^0"
S ^BGPPEDPT(BGPRPT,99999,0)="^90377.13999A^0^0"
S ^BGPPEDBT(BGPRPT,99999,0)="^90377.14999A^0^0"
REPORTX ;
D ^XBFMK
K DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
L -^BGPPEDCT
L -^BGPPEDPT
L -^BGPPEDBT
Q
GETIEN ;EP -Get next ien available in all 3 files
S BGPF=90377.12 D ENT
S BGPF=90377.13 D ENT
S BGPF=90377.14 D ENT
S BGPIEN=$P(^BGPPEDCT(0),U,3)+1
S I $D(^BGPPEDPT(BGPIEN))!($D(^BGPPEDBT(BGPIEN))) S BGPIEN=BGPIEN+1 G S
Q
;
ENT ;
NEW GBL,NXT,CTR,XBHI,XBX,XBY,ANS
S GBL=^DIC(BGPF,0,"GL")
S GBL=GBL_"NXT)"
S (XBHI,NXT,CTR)=0
F L=0:0 S NXT=$O(@(GBL)) Q:NXT'=+NXT S XBHI=NXT,CTR=CTR+1 ;W:'(CTR#50) "."
S NXT="",XBX=$O(@(GBL)),XBX=^(0),XBY=$P(XBX,U,4),XBX=$P(XBX,U,3)
S NXT=0,$P(@(GBL),U,3)=XBHI,$P(^(0),U,4)=CTR
;
EOJ ;
KILL ANS,XBHI,XBX,XBY,CTR,DIC,FILE,GBL,L,NXT,BGPF
Q
;
BGP0PUTL ; IHS/CMI/LAB - ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+2 ;
+3 ;
+4 ;utility calls
+5 ;
STMP ;EP
+1 IF BGPTIME'=1
QUIT
+2 IF BGPLIST="P"
IF $PIECE(^AUPNPAT(DFN,0),U,14)'=BGPLPRV
QUIT
+3 XECUTE ^BGPPEIT(BGPIC,2)
IF '$TEST
QUIT
+4 SET BGPLIST(BGPIC)=$GET(BGPLIST(BGPIC))+1
+5 SET ^XTMP("BGP0D",BGPJ,BGPH,"LIST",BGPIC,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),BGPAGEB,DFN)=BGPVALUE
+6 QUIT
D(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT (1700+$EXTRACT(D,1,3))_$EXTRACT(D,4,5)_$EXTRACT(D,6,7)_$SELECT($PIECE(D,".",2)]"":$PIECE(D,".",2),1:"")
JRNL ;EP
+1 NEW (DT,U,ZTQUEUED)
SET %=$$NOJOURN^ZIBGCHAR("BGPPEDCT")
SET %=$$NOJOURN^ZIBGCHAR("BGPPEDPT")
SET %=$$NOJOURN^ZIBGCHAR("BGPPEDBT")
+2 QUIT
DATE(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+3 ;
GS ;EP
+1 KILL ^TMP($JOB)
+2 IF $PIECE($GET(^BGPSITE(DUZ(2),0)),U,3)="N"
QUIT
+3 LOCK +^BGPDATA:300
IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE "Unable to lock global"
QUIT
+4 ;NOTE: Kill of unscripted global. Export to area. Using standard name.
KILL ^BGPDATA
+5 SET X=""
SET C=0
FOR
SET X=$ORDER(^BGPPEDCT(BGPRPT,X))
IF X'=+X!(X>99998)
QUIT
Begin DoDot:1
+6 IF $GET(^BGPPEDCT(BGPRPT,X))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDCT(BGPRPT,X)
+7 SET X2=""
FOR
SET X2=$ORDER(^BGPPEDCT(BGPRPT,X,X2))
IF X2'=+X2
QUIT
Begin DoDot:2
+8 IF $GET(^BGPPEDCT(BGPRPT,X,X2))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDCT(BGPRPT,X,X2)
+9 SET X3=""
FOR
SET X3=$ORDER(^BGPPEDCT(BGPRPT,X,X2,X3))
IF X3'=+X3
QUIT
Begin DoDot:3
+10 IF $GET(^BGPPEDCT(BGPRPT,X,X2,X3))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDCT(BGPRPT,X,X2,X3)
+11 SET X4=""
FOR
SET X4=$ORDER(^BGPPEDCT(BGPRPT,X,X2,X3,X4))
IF X4'=+X4
QUIT
Begin DoDot:4
+12 IF $GET(^BGPPEDCT(BGPRPT,X,X2,X3,X4))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDCT(BGPRPT,X,X2,X3,X4)
+13 SET X5=""
FOR
SET X5=$ORDER(^BGPPEDCT(BGPRPT,X,X2,X3,X4,X5))
IF X5'=+X5
QUIT
Begin DoDot:5
+14 IF $GET(^BGPPEDCT(BGPRPT,X,X2,X3,X4,X5))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
+15 SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",5)=X5
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDCT(BGPRPT,X,X2,X3,X4,X5)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 SET X=0
FOR
SET X=$ORDER(^BGPDATA(X))
IF X'=+X
QUIT
SET ^BGPDATA(X)="BGPPEDCT"_"|"_^BGPDATA(X)
PRGS ;
+1 SET S=C+1
SET X=""
FOR
SET X=$ORDER(^BGPPEDPT(BGPRPT,X))
IF X'=+X!(X>99998)
QUIT
Begin DoDot:1
+2 IF $GET(^BGPPEDPT(BGPRPT,X))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDPT(BGPRPT,X)
+3 SET X2=""
FOR
SET X2=$ORDER(^BGPPEDPT(BGPRPT,X,X2))
IF X2'=+X2
QUIT
Begin DoDot:2
+4 IF $GET(^BGPPEDPT(BGPRPT,X,X2))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDPT(BGPRPT,X,X2)
+5 SET X3=""
FOR
SET X3=$ORDER(^BGPPEDPT(BGPRPT,X,X2,X3))
IF X3'=+X3
QUIT
Begin DoDot:3
+6 IF $GET(^BGPPEDPT(BGPRPT,X,X2,X3))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDPT(BGPRPT,X,X2,X3)
+7 SET X4=""
FOR
SET X4=$ORDER(^BGPPEDPT(BGPRPT,X,X2,X3,X4))
IF X4'=+X4
QUIT
Begin DoDot:4
+8 IF $GET(^BGPPEDPT(BGPRPT,X,X2,X3,X4))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDPT(BGPRPT,X,X2,X3,X4)
+9 SET X5=""
FOR
SET X5=$ORDER(^BGPPEDPT(BGPRPT,X,X2,X3,X4,X5))
IF X5'=+X5
QUIT
Begin DoDot:5
+10 IF $GET(^BGPPEDPT(BGPRPT,X,X2,X3,X4,X5))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
+11 SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",5)=X5
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDPT(BGPRPT,X,X2,X3,X4,X5)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 SET X=S-1
FOR
SET X=$ORDER(^BGPDATA(X))
IF X'=+X
QUIT
SET ^BGPDATA(X)="BGPPEDPT"_"|"_^BGPDATA(X)
BLGS ;save off baseline data
+1 SET S=C+1
SET X=""
FOR
SET X=$ORDER(^BGPPEDBT(BGPRPT,X))
IF X'=+X!(X>99998)
QUIT
Begin DoDot:1
+2 IF $GET(^BGPPEDBT(BGPRPT,X))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDBT(BGPRPT,X)
+3 SET X2=""
FOR
SET X2=$ORDER(^BGPPEDBT(BGPRPT,X,X2))
IF X2'=+X2
QUIT
Begin DoDot:2
+4 IF $GET(^BGPPEDBT(BGPRPT,X,X2))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDBT(BGPRPT,X,X2)
+5 SET X3=""
FOR
SET X3=$ORDER(^BGPPEDBT(BGPRPT,X,X2,X3))
IF X3'=+X3
QUIT
Begin DoDot:3
+6 IF $GET(^BGPPEDBT(BGPRPT,X,X2,X3))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDBT(BGPRPT,X,X2,X3)
+7 SET X4=""
FOR
SET X4=$ORDER(^BGPPEDBT(BGPRPT,X,X2,X3,X4))
IF X4'=+X4
QUIT
Begin DoDot:4
+8 IF $GET(^BGPPEDBT(BGPRPT,X,X2,X3,X4))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDBT(BGPRPT,X,X2,X3,X4)
+9 SET X5=""
FOR
SET X5=$ORDER(^BGPPEDBT(BGPRPT,X,X2,X3,X4,X5))
IF X5'=+X5
QUIT
Begin DoDot:5
+10 IF $GET(^BGPPEDBT(BGPRPT,X,X2,X3,X4,X5))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
+11 SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",5)=X5
SET $PIECE(^BGPDATA(C),"|",8)=^BGPPEDBT(BGPRPT,X,X2,X3,X4,X5)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 SET X=S-1
FOR
SET X=$ORDER(^BGPDATA(X))
IF X'=+X
QUIT
SET ^BGPDATA(X)="BGPPEDBT"_"|"_^BGPDATA(X)
+13 NEW XBGL
SET XBGL="BGPDATA"
+14 SET F="BG10"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_".PED"_BGPRPT
+15 NEW XBMED,XBFN,XBTLE,XBF,XBFLT
+16 SET XBMED="F"
SET XBFN=F
SET XBTLE="SAVE OF GPRA DATA BY - "_$PIECE(^VA(200,DUZ,0),U)
SET XBF=0
SET XBFLT=1
+17 DO ^XBGSAVE
+18 LOCK -^BGPDATA
+19 ;NOTE: kill of unsubscripted global for use in export to area.
KILL ^TMP($JOB),^BGPDATA
+20 QUIT
REPORT ;EP
+1 SET BGPRPT=""
+2 WRITE !!
+3 ;CREATE REPORT ENTRY IN FILEMAN FILE
+4 ;3 files must have the same ien
+5 LOCK +^BGPPEDCT:30
IF '$TEST
WRITE !!,"Unable to lock global, try later."
GOTO REPORTX
+6 LOCK +^BGPPEDPT:30
IF '$TEST
WRITE !!,"Unable to lock global, try later."
GOTO REPORTX
+7 LOCK +^BGPPEDBT:30
IF '$TEST
WRITE !!,"Unable to lock global, try later."
GOTO REPORTX
+8 DO GETIEN
+9 IF 'BGPIEN
WRITE !!,"Something wrong with control files, notify programmer!"
SET BGPRPT=""
GOTO REPORTX
+10 SET DINUM=BGPIEN
+11 KILL DIC
SET X=BGPBD
SET DIC(0)="L"
SET DIC="^BGPPEDCT("
SET DLAYGO=90377.12
SET DIADD=1
SET DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$GET(BGPPER)_";.08////"_$GET(BGPQTR)
+12 SET DIC("DR")=DIC("DR")_";.09////"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_";.1////"_$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.13////"_DT_";.11////"_BGPBEN_";.12////"_$PIECE($GET(^AUTTLOC(DUZ(2),1)),U,3)
+13 SET DIC("DR")=DIC("DR")_";.17///"_$PIECE(^BGPSITE(DUZ(2),0),U,6)
+14 DO ^DIC
KILL DIC,DA,DR,DIADD,DLAYGO
IF Y=-1
WRITE !!,"UNABLE TO CREATE REPORT FILE ENTRY - NOTIFY SITE MANAGER!"
SET BGPQUIT=1
GOTO REPORTX
+15 SET BGPRPT=+Y
+16 KILL DIC
SET X=BGPBD
SET DIC(0)="L"
SET DIC="^BGPPEDPT("
SET DLAYGO=90377.13
SET DIADD=1
SET DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$GET(BGPPER)_";.08////"_$GET(BGPQTR)
+17 SET DIC("DR")=DIC("DR")_";.09////"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_";.1////"_$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.13////"_DT_";.11////"_BGPBEN_";.12////"_$PIECE($GET(^AUTTLOC(DUZ(2),1)),U,3)
+18 SET DIC("DR")=DIC("DR")_";.17///"_$PIECE(^BGPSITE(DUZ(2),0),U,6)
+19 SET DINUM=BGPRPT
DO ^DIC
KILL DIC,DA,DR,DIADD,DLAYGO,DINUM
IF Y=-1
WRITE !!,"UNABLE TO CREATE REPORT FILE ENTRY - NOTIFY SITE MANAGER!"
SET BGPQUIT=1
GOTO REPORTX
+20 SET BGPRPTP=+Y
+21 KILL DIC
SET X=BGPBD
SET DIC(0)="L"
SET DIC="^BGPPEDBT("
SET DLAYGO=90377.14
SET DIADD=1
SET DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$GET(BGPPER)_";.08////"_$GET(BGPQTR)
+22 SET DIC("DR")=DIC("DR")_";.09////"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_";.1////"_$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.13////"_DT_";.11////"_BGPBEN_";.12////"_$PIECE($GET(^AUTTLOC(DUZ(2),1)),U,3)
+23 SET DIC("DR")=DIC("DR")_";.17///"_$PIECE(^BGPSITE(DUZ(2),0),U,6)
+24 SET DINUM=BGPRPT
DO ^DIC
KILL DIC,DA,DR,DIADD,DLAYGO
IF Y=-1
WRITE !!,"UNABLE TO CREATE REPORT FILE ENTRY - NOTIFY SITE MANAGER!"
SET BGPQUIT=1
GOTO REPORTX
+25 SET BGPRPTB=+Y
+26 ;add communities to 28 multiple
+27 KILL ^BGPPEDCT(BGPRPT,9999)
+28 SET C=0
SET X=""
FOR
SET X=$ORDER(BGPTAX(X))
IF X=""
QUIT
SET C=C+1
SET ^BGPPEDCT(BGPRPT,9999,C,0)=X
SET ^BGPPEDCT(BGPRPT,9999,"B",X,C)=""
+29 SET ^BGPPEDCT(BGPRPT,9999,0)="^90377.12999A^"_C_"^"_C
+30 IF $GET(BGPMFITI)
SET C=0
SET X=""
FOR
SET X=$ORDER(^ATXAX(BGPMFITI,21,"B",X))
IF X=""
QUIT
SET C=C+1
SET Y=$PIECE($GET(^DIC(4,X,0)),U)
SET ^BGPPEDCT(BGPRPT,1111,C,0)=Y
SET ^BGPPEDCT(BGPRPT,1111,"B",Y,C)=""
+31 SET ^BGPPEDCT(BGPRPT,1111,0)="^90377.12111^"_C_"^"_C
+32 SET ^BGPPEDCT(BGPRPT,99999,0)="^90377.12999A^0^0"
+33 SET ^BGPPEDPT(BGPRPT,99999,0)="^90377.13999A^0^0"
+34 SET ^BGPPEDBT(BGPRPT,99999,0)="^90377.14999A^0^0"
REPORTX ;
+1 DO ^XBFMK
+2 KILL DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
+3 LOCK -^BGPPEDCT
+4 LOCK -^BGPPEDPT
+5 LOCK -^BGPPEDBT
+6 QUIT
GETIEN ;EP -Get next ien available in all 3 files
+1 SET BGPF=90377.12
DO ENT
+2 SET BGPF=90377.13
DO ENT
+3 SET BGPF=90377.14
DO ENT
+4 SET BGPIEN=$PIECE(^BGPPEDCT(0),U,3)+1
S IF $DATA(^BGPPEDPT(BGPIEN))!($DATA(^BGPPEDBT(BGPIEN)))
SET BGPIEN=BGPIEN+1
GOTO S
+1 QUIT
+2 ;
ENT ;
+1 NEW GBL,NXT,CTR,XBHI,XBX,XBY,ANS
+2 SET GBL=^DIC(BGPF,0,"GL")
+3 SET GBL=GBL_"NXT)"
+4 SET (XBHI,NXT,CTR)=0
+5 ;W:'(CTR#50) "."
FOR L=0:0
SET NXT=$ORDER(@(GBL))
IF NXT'=+NXT
QUIT
SET XBHI=NXT
SET CTR=CTR+1
+6 SET NXT=""
SET XBX=$ORDER(@(GBL))
SET XBX=^(0)
SET XBY=$PIECE(XBX,U,4)
SET XBX=$PIECE(XBX,U,3)
+7 SET NXT=0
SET $PIECE(@(GBL),U,3)=XBHI
SET $PIECE(^(0),U,4)=CTR
+8 ;
EOJ ;
+1 KILL ANS,XBHI,XBX,XBY,CTR,DIC,FILE,GBL,L,NXT,BGPF
+2 QUIT
+3 ;
