- BGP4EUTL ; IHS/CMI/LAB - ;
- ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
- ;
- ;
- ;utility calls
- ;
- STMP ;EP
- Q:BGPTIME'=1
- I BGPLIST="P",$P(^AUPNPAT(DFN,0),U,14)'=BGPLPRV Q
- X ^BGPELIJ(BGPIC,2) Q:'$T
- S BGPLIST(BGPIC)=$G(BGPLIST(BGPIC))+1
- S ^XTMP("BGP4D",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("BGPELDCJ"),%=$$NOJOURN^ZIBGCHAR("BGPELDPJ"),%=$$NOJOURN^ZIBGCHAR("BGPELDBJ")
- 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(^BGPELDCJ(BGPRPT,X)) Q:X'=+X!(X>99998) D
- .I $G(^BGPELDCJ(BGPRPT,X))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",8)=^BGPELDCJ(BGPRPT,X)
- .S X2="" F S X2=$O(^BGPELDCJ(BGPRPT,X,X2)) Q:X2'=+X2 D
- ..I $G(^BGPELDCJ(BGPRPT,X,X2))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",8)=^BGPELDCJ(BGPRPT,X,X2)
- ..S X3="" F S X3=$O(^BGPELDCJ(BGPRPT,X,X2,X3)) Q:X3'=+X3 D
- ...I $G(^BGPELDCJ(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)=^BGPELDCJ(BGPRPT,X,X2,X3)
- ...S X4="" F S X4=$O(^BGPELDCJ(BGPRPT,X,X2,X3,X4)) Q:X4'=+X4 D
- ....I $G(^BGPELDCJ(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)=^BGPELDCJ(BGPRPT,X,X2,X3,X4)
- ....S X5="" F S X5=$O(^BGPELDCJ(BGPRPT,X,X2,X3,X4,X5)) Q:X5'=+X5 D
- .....I $G(^BGPELDCJ(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)=^BGPELDCJ(BGPRPT,X,X2,X3,X4,X5)
- S X=0 F S X=$O(^BGPDATA(X)) Q:X'=+X S ^BGPDATA(X)="BGPELDCJ"_"|"_^BGPDATA(X)
- PRGS ;
- S S=C+1,X="" F S X=$O(^BGPELDPJ(BGPRPT,X)) Q:X'=+X!(X>99998) D
- .I $G(^BGPELDPJ(BGPRPT,X))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",8)=^BGPELDPJ(BGPRPT,X)
- .S X2="" F S X2=$O(^BGPELDPJ(BGPRPT,X,X2)) Q:X2'=+X2 D
- ..I $G(^BGPELDPJ(BGPRPT,X,X2))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",8)=^BGPELDPJ(BGPRPT,X,X2)
- ..S X3="" F S X3=$O(^BGPELDPJ(BGPRPT,X,X2,X3)) Q:X3'=+X3 D
- ...I $G(^BGPELDPJ(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)=^BGPELDPJ(BGPRPT,X,X2,X3)
- ...S X4="" F S X4=$O(^BGPELDPJ(BGPRPT,X,X2,X3,X4)) Q:X4'=+X4 D
- ....I $G(^BGPELDPJ(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)=^BGPELDPJ(BGPRPT,X,X2,X3,X4)
- ....S X5="" F S X5=$O(^BGPELDPJ(BGPRPT,X,X2,X3,X4,X5)) Q:X5'=+X5 D
- .....I $G(^BGPELDPJ(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)=^BGPELDPJ(BGPRPT,X,X2,X3,X4,X5)
- S X=S-1 F S X=$O(^BGPDATA(X)) Q:X'=+X S ^BGPDATA(X)="BGPELDPJ"_"|"_^BGPDATA(X)
- BLGS ;save off baseline data
- S S=C+1,X="" F S X=$O(^BGPELDBJ(BGPRPT,X)) Q:X'=+X!(X>99998) D
- .I $G(^BGPELDBJ(BGPRPT,X))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",8)=^BGPELDBJ(BGPRPT,X)
- .S X2="" F S X2=$O(^BGPELDBJ(BGPRPT,X,X2)) Q:X2'=+X2 D
- ..I $G(^BGPELDBJ(BGPRPT,X,X2))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",8)=^BGPELDBJ(BGPRPT,X,X2)
- ..S X3="" F S X3=$O(^BGPELDBJ(BGPRPT,X,X2,X3)) Q:X3'=+X3 D
- ...I $G(^BGPELDBJ(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)=^BGPELDBJ(BGPRPT,X,X2,X3)
- ...S X4="" F S X4=$O(^BGPELDBJ(BGPRPT,X,X2,X3,X4)) Q:X4'=+X4 D
- ....I $G(^BGPELDBJ(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)=^BGPELDBJ(BGPRPT,X,X2,X3,X4)
- ....S X5="" F S X5=$O(^BGPELDBJ(BGPRPT,X,X2,X3,X4,X5)) Q:X5'=+X5 D
- .....I $G(^BGPELDBJ(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)=^BGPELDBJ(BGPRPT,X,X2,X3,X4,X5)
- S X=S-1 F S X=$O(^BGPDATA(X)) Q:X'=+X S ^BGPDATA(X)="BGPELDBJ"_"|"_^BGPDATA(X)
- NEW XBGL S XBGL="BGPDATA"
- S F="BG141"_$P(^AUTTLOC(DUZ(2),0),U,10)_".EL"_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
- S XBUF=BGPUF 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 +^BGPELDCJ:30 I '$T W !!,"Unable to lock global, try later." G REPORTX
- L +^BGPELDPJ:30 I '$T W !!,"Unable to lock global, try later." G REPORTX
- L +^BGPELDBJ: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="^BGPELDCJ(",DLAYGO=90553.03,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)_";.11////"_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.12////"_BGPRTYPE_";.13////"_DT_";.14////"_BGPBEN_";.15////"_$P($G(^AUTTLOC(DUZ(2),1)),U,3)
- S DIC("DR")=DIC("DR")_";.17///"_$P(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$S($G(BGPTAXI):$P(^ATXAX(BGPTAXI,0),U),1:"")_";.19///"_$P(^BGPSITE(DUZ(2),0),U,13)
- 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="^BGPELDPJ(",DLAYGO=90553.04,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)_";.11////"_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.12////"_BGPRTYPE_";.13////"_DT_";.14////"_BGPBEN_";.15////"_$P($G(^AUTTLOC(DUZ(2),1)),U,3)
- S DIC("DR")=DIC("DR")_";.17///"_$P(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$S($G(BGPTAXI):$P(^ATXAX(BGPTAXI,0),U),1:"")_";.19///"_$P(^BGPSITE(DUZ(2),0),U,13)
- 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="^BGPELDBJ(",DLAYGO=90553.05,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)_";.11////"_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.12////"_BGPRTYPE_";.13////"_DT_";.14////"_BGPBEN_";.15////"_$P($G(^AUTTLOC(DUZ(2),1)),U,3)
- S DIC("DR")=DIC("DR")_";.17///"_$P(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$S($G(BGPTAXI):$P(^ATXAX(BGPTAXI,0),U),1:"")_";.19///"_$P(^BGPSITE(DUZ(2),0),U,13)
- 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 ^BGPELDCJ(BGPRPT,9999)
- S C=0,X="" F S X=$O(BGPTAX(X)) Q:X="" S C=C+1 S ^BGPELDCJ(BGPRPT,9999,C,0)=X,^BGPELDCJ(BGPRPT,9999,"B",X,C)=""
- S ^BGPELDCJ(BGPRPT,9999,0)="^90553.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 ^BGPELDCJ(BGPRPT,1111,C,0)=Y,^BGPELDCJ(BGPRPT,1111,"B",Y,C)=""
- S ^BGPELDCJ(BGPRPT,1111,0)="^90553.031111^"_C_"^"_C
- S ^BGPELDCJ(BGPRPT,99999,0)="^90553.129999A^0^0"
- S ^BGPELDPJ(BGPRPT,99999,0)="^90553.139999A^0^0"
- S ^BGPELDBJ(BGPRPT,99999,0)="^90553.149999A^0^0"
- REPORTX ;
- D ^XBFMK
- K DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
- L -^BGPELDCJ
- L -^BGPELDPJ
- L -^BGPELDBJ
- Q
- GETIEN ;EP -Get next ien available in all 3 files
- S BGPF=90553.03 D ENT
- S BGPF=90553.04 D ENT
- S BGPF=90553.05 D ENT
- S BGPIEN=$P(^BGPELDCJ(0),U,3)+1
- S I $D(^BGPELDPJ(BGPIEN))!($D(^BGPELDBJ(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
- ;
- BGP4EUTL ; IHS/CMI/LAB - ;
- +1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
- +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 ^BGPELIJ(BGPIC,2)
- IF '$TEST
- QUIT
- +4 SET BGPLIST(BGPIC)=$GET(BGPLIST(BGPIC))+1
- +5 SET ^XTMP("BGP4D",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("BGPELDCJ")
- SET %=$$NOJOURN^ZIBGCHAR("BGPELDPJ")
- SET %=$$NOJOURN^ZIBGCHAR("BGPELDBJ")
- +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 ;I $P($G(^BGPSITE(DUZ(2),0)),U,3)="N" Q
- +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(^BGPELDCJ(BGPRPT,X))
- IF X'=+X!(X>99998)
- QUIT
- Begin DoDot:1
- +6 IF $GET(^BGPELDCJ(BGPRPT,X))]""
- SET C=C+1
- SET $PIECE(^BGPDATA(C),"|")=X
- SET $PIECE(^BGPDATA(C),"|",8)=^BGPELDCJ(BGPRPT,X)
- +7 SET X2=""
- FOR
- SET X2=$ORDER(^BGPELDCJ(BGPRPT,X,X2))
- IF X2'=+X2
- QUIT
- Begin DoDot:2
- +8 IF $GET(^BGPELDCJ(BGPRPT,X,X2))]""
- SET C=C+1
- SET $PIECE(^BGPDATA(C),"|")=X
- SET $PIECE(^BGPDATA(C),"|",2)=X2
- SET $PIECE(^BGPDATA(C),"|",8)=^BGPELDCJ(BGPRPT,X,X2)
- +9 SET X3=""
- FOR
- SET X3=$ORDER(^BGPELDCJ(BGPRPT,X,X2,X3))
- IF X3'=+X3
- QUIT
- Begin DoDot:3
- +10 IF $GET(^BGPELDCJ(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)=^BGPELDCJ(BGPRPT,X,X2,X3)
- +11 SET X4=""
- FOR
- SET X4=$ORDER(^BGPELDCJ(BGPRPT,X,X2,X3,X4))
- IF X4'=+X4
- QUIT
- Begin DoDot:4
- +12 IF $GET(^BGPELDCJ(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)=^BGPELDCJ(BGPRPT,X,X2,X3,X4)
- +13 SET X5=""
- FOR
- SET X5=$ORDER(^BGPELDCJ(BGPRPT,X,X2,X3,X4,X5))
- IF X5'=+X5
- QUIT
- Begin DoDot:5
- +14 IF $GET(^BGPELDCJ(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)=^BGPELDCJ(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)="BGPELDCJ"_"|"_^BGPDATA(X)
- PRGS ;
- +1 SET S=C+1
- SET X=""
- FOR
- SET X=$ORDER(^BGPELDPJ(BGPRPT,X))
- IF X'=+X!(X>99998)
- QUIT
- Begin DoDot:1
- +2 IF $GET(^BGPELDPJ(BGPRPT,X))]""
- SET C=C+1
- SET $PIECE(^BGPDATA(C),"|")=X
- SET $PIECE(^BGPDATA(C),"|",8)=^BGPELDPJ(BGPRPT,X)
- +3 SET X2=""
- FOR
- SET X2=$ORDER(^BGPELDPJ(BGPRPT,X,X2))
- IF X2'=+X2
- QUIT
- Begin DoDot:2
- +4 IF $GET(^BGPELDPJ(BGPRPT,X,X2))]""
- SET C=C+1
- SET $PIECE(^BGPDATA(C),"|")=X
- SET $PIECE(^BGPDATA(C),"|",2)=X2
- SET $PIECE(^BGPDATA(C),"|",8)=^BGPELDPJ(BGPRPT,X,X2)
- +5 SET X3=""
- FOR
- SET X3=$ORDER(^BGPELDPJ(BGPRPT,X,X2,X3))
- IF X3'=+X3
- QUIT
- Begin DoDot:3
- +6 IF $GET(^BGPELDPJ(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)=^BGPELDPJ(BGPRPT,X,X2,X3)
- +7 SET X4=""
- FOR
- SET X4=$ORDER(^BGPELDPJ(BGPRPT,X,X2,X3,X4))
- IF X4'=+X4
- QUIT
- Begin DoDot:4
- +8 IF $GET(^BGPELDPJ(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)=^BGPELDPJ(BGPRPT,X,X2,X3,X4)
- +9 SET X5=""
- FOR
- SET X5=$ORDER(^BGPELDPJ(BGPRPT,X,X2,X3,X4,X5))
- IF X5'=+X5
- QUIT
- Begin DoDot:5
- +10 IF $GET(^BGPELDPJ(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)=^BGPELDPJ(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)="BGPELDPJ"_"|"_^BGPDATA(X)
- BLGS ;save off baseline data
- +1 SET S=C+1
- SET X=""
- FOR
- SET X=$ORDER(^BGPELDBJ(BGPRPT,X))
- IF X'=+X!(X>99998)
- QUIT
- Begin DoDot:1
- +2 IF $GET(^BGPELDBJ(BGPRPT,X))]""
- SET C=C+1
- SET $PIECE(^BGPDATA(C),"|")=X
- SET $PIECE(^BGPDATA(C),"|",8)=^BGPELDBJ(BGPRPT,X)
- +3 SET X2=""
- FOR
- SET X2=$ORDER(^BGPELDBJ(BGPRPT,X,X2))
- IF X2'=+X2
- QUIT
- Begin DoDot:2
- +4 IF $GET(^BGPELDBJ(BGPRPT,X,X2))]""
- SET C=C+1
- SET $PIECE(^BGPDATA(C),"|")=X
- SET $PIECE(^BGPDATA(C),"|",2)=X2
- SET $PIECE(^BGPDATA(C),"|",8)=^BGPELDBJ(BGPRPT,X,X2)
- +5 SET X3=""
- FOR
- SET X3=$ORDER(^BGPELDBJ(BGPRPT,X,X2,X3))
- IF X3'=+X3
- QUIT
- Begin DoDot:3
- +6 IF $GET(^BGPELDBJ(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)=^BGPELDBJ(BGPRPT,X,X2,X3)
- +7 SET X4=""
- FOR
- SET X4=$ORDER(^BGPELDBJ(BGPRPT,X,X2,X3,X4))
- IF X4'=+X4
- QUIT
- Begin DoDot:4
- +8 IF $GET(^BGPELDBJ(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)=^BGPELDBJ(BGPRPT,X,X2,X3,X4)
- +9 SET X5=""
- FOR
- SET X5=$ORDER(^BGPELDBJ(BGPRPT,X,X2,X3,X4,X5))
- IF X5'=+X5
- QUIT
- Begin DoDot:5
- +10 IF $GET(^BGPELDBJ(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)=^BGPELDBJ(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)="BGPELDBJ"_"|"_^BGPDATA(X)
- +13 NEW XBGL
- SET XBGL="BGPDATA"
- +14 SET F="BG141"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_".EL"_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 SET XBUF=BGPUF
- 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 +^BGPELDCJ:30
- IF '$TEST
- WRITE !!,"Unable to lock global, try later."
- GOTO REPORTX
- +6 LOCK +^BGPELDPJ:30
- IF '$TEST
- WRITE !!,"Unable to lock global, try later."
- GOTO REPORTX
- +7 LOCK +^BGPELDBJ: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="^BGPELDCJ("
- SET DLAYGO=90553.03
- 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)_";.11////"_$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.12////"_BGPRTYPE_";.13////"_DT_";.14////"_BGPBEN_";.15////"_$PIECE($GET(^AUTTLOC(DUZ(2),1)),U,3)
- +13 SET DIC("DR")=DIC("DR")_";.17///"_$PIECE(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$SELECT($GET(BGPTAXI):$PIECE(^ATXAX(BGPTAXI,0),U),1:"")_";.19///"_$PIECE(^BGPSITE(DUZ(2),0),U,13)
- +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="^BGPELDPJ("
- SET DLAYGO=90553.04
- 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)_";.11////"_$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.12////"_BGPRTYPE_";.13////"_DT_";.14////"_BGPBEN_";.15////"_$PIECE($GET(^AUTTLOC(DUZ(2),1)),U,3)
- +18 SET DIC("DR")=DIC("DR")_";.17///"_$PIECE(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$SELECT($GET(BGPTAXI):$PIECE(^ATXAX(BGPTAXI,0),U),1:"")_";.19///"_$PIECE(^BGPSITE(DUZ(2),0),U,13)
- +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="^BGPELDBJ("
- SET DLAYGO=90553.05
- 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)_";.11////"_$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.12////"_BGPRTYPE_";.13////"_DT_";.14////"_BGPBEN_";.15////"_$PIECE($GET(^AUTTLOC(DUZ(2),1)),U,3)
- +23 SET DIC("DR")=DIC("DR")_";.17///"_$PIECE(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$SELECT($GET(BGPTAXI):$PIECE(^ATXAX(BGPTAXI,0),U),1:"")_";.19///"_$PIECE(^BGPSITE(DUZ(2),0),U,13)
- +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 ^BGPELDCJ(BGPRPT,9999)
- +28 SET C=0
- SET X=""
- FOR
- SET X=$ORDER(BGPTAX(X))
- IF X=""
- QUIT
- SET C=C+1
- SET ^BGPELDCJ(BGPRPT,9999,C,0)=X
- SET ^BGPELDCJ(BGPRPT,9999,"B",X,C)=""
- +29 SET ^BGPELDCJ(BGPRPT,9999,0)="^90553.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 ^BGPELDCJ(BGPRPT,1111,C,0)=Y
- SET ^BGPELDCJ(BGPRPT,1111,"B",Y,C)=""
- +31 SET ^BGPELDCJ(BGPRPT,1111,0)="^90553.031111^"_C_"^"_C
- +32 SET ^BGPELDCJ(BGPRPT,99999,0)="^90553.129999A^0^0"
- +33 SET ^BGPELDPJ(BGPRPT,99999,0)="^90553.139999A^0^0"
- +34 SET ^BGPELDBJ(BGPRPT,99999,0)="^90553.149999A^0^0"
- REPORTX ;
- +1 DO ^XBFMK
- +2 KILL DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
- +3 LOCK -^BGPELDCJ
- +4 LOCK -^BGPELDPJ
- +5 LOCK -^BGPELDBJ
- +6 QUIT
- GETIEN ;EP -Get next ien available in all 3 files
- +1 SET BGPF=90553.03
- DO ENT
- +2 SET BGPF=90553.04
- DO ENT
- +3 SET BGPF=90553.05
- DO ENT
- +4 SET BGPIEN=$PIECE(^BGPELDCJ(0),U,3)+1
- S IF $DATA(^BGPELDPJ(BGPIEN))!($DATA(^BGPELDBJ(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 ;
