BGP9ULF ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 27 May 2009 4:26 PM ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
;
W:$D(IOF) @IOF
W !,"This option is used to upload a SU's 2009 CRS data.",!,"You must specify the directory in which the CRS 2009 data file resides",!,"and then enter the filename of the data.",!
FILE ;
D HOME^%ZIS
DIR ;
K DIR
S BGPDIR=""
S DIR(0)="FO^3:50",DIR("A")="Enter directory path (i.e. /usr/spool/uucppublic/)" K DA D ^DIR K DIR
I $D(DIRUT) W !!,"Directory not entered!! Bye." G EOJ
I Y="" W !!,"Directory not entered!! Bye." G EOJ
S BGPDIR=Y
FILENAME ;
W !!
S BGPFILE=""
S DIR(0)="FO^2:30",DIR("A")="Enter filename w /ext (i.e. BG09101201.5)" K DA D ^DIR K DIR
G:$D(DIRUT) DIR
I Y="" G DIR
I $E($$UP^XLFSTR(Y),1,4)'="BG09" W !!,"Filename must begin with BG09" G FILENAME
S BGPFILE=Y
W !,"Directory=",BGPDIR," ","File=",BGPFILE
D READF
G FILENAME
READF ;EP read file
NEW Y,X,I,BGPC
S BGPC=1
S Y=$$OPEN^%ZISH(BGPDIR,BGPFILE,"R")
I Y W !,*7,"CANNOT OPEN (OR ACCESS) FILE '",BGPDIR,BGPFILE,"'." G EOJ
KILL ^TMP("BGPUPL",$J)
F I=1:1 U IO R X:DTIME S X=$$STRIP(X) Q:X="" S ^TMP("BGPUPL",$J,BGPC,0)=X,BGPC=BGPC+1 Q:$$STATUS^%ZISH=-1
D ^%ZISC
W !!,"All done reading file",!
PROC ;
I $P(BGPFILE,".",2)["HE" D PROCHE Q
I $P(BGPFILE,".",2)["EL" D PROCEL Q
I $P(BGPFILE,".",2)["PED" D PROCPED Q
I $P(BGPFILE,".",2)["EO" D PROCEO^BGP9ULF1 Q
;I $P(BGPFILE,".",2)["ON" D PROCON Q
W !,"Processing",!
S BGP0=$P($G(^TMP("BGPUPL",$J,1,0)),"|",9)
S BGPG=$P($G(^TMP("BGPUPL",$J,1,0)),"|")
F X=1:1:14 S Y="BGP"_X,@Y=$P(BGP0,U,X)
;find existing entry and if exists, delete it
S (X,BGPOIEN)=0 F S X=$O(^BGPGPDCN(X)) Q:X'=+X D
.I '$D(^BGPGPDCN(X,0)) K ^BGPGPDCN(X) Q
.S Y=^BGPGPDCN(X,0)
.Q:$P(Y,U)'=BGP1
.Q:$P(Y,U,2)'=BGP2
.Q:$P(Y,U,3)'=BGP3
.Q:$P(Y,U,4)'=BGP4
.Q:$P(Y,U,5)'=BGP5
.Q:$P(Y,U,6)'=BGP6
.Q:$P(Y,U,8)'=BGP8
.Q:$P(Y,U,9)'=BGP9
.Q:$P(Y,U,10)'=BGP10
.Q:$P(Y,U,11)'=BGP11
.Q:$P(Y,U,12)'=BGP12
.Q:$P(Y,U,14)'=BGP14
.S BGPOIEN=X
D ^XBFMK
I BGPOIEN S DA=BGPOIEN,DIK="^BGPGPDCN(" D ^DIK S DA=BGPOIEN,DIK="^BGPGPDPN(" D ^DIK S DA=BGPOIEN,DIK="^BGPGPDBN(" D ^DIK
;add entry
L +^BGPGPDCN:10 I '$T W !!,"unable to lock global. TRY LATER" D EOJ Q
L +^BGPGPDPN:10 I '$T W !!,"unable to lock global. TRY LATER" D EOJ Q
L +^BGPGPDBN:10 I '$T W !!,"unable to lock global. TRY LATER" D EOJ Q
D GETIEN^BGP9UTL
I 'BGPIEN W !!,"error in file creation...call programmer." D EOJ Q
CY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90536.03,DIC="^BGPGPDCN(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 W !,"error uploading file......" H 4 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPGPDCN"
.S V=$P(V,"|",2,9999)
.S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
.I N5]"" S ^BGPGPDCN(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPGPDCN(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPGPDCN(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPGPDCN(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPGPDCN(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPGPDCN(" D IX1^DIK
PY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90536.04,DIC="^BGPGPDPN(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 W !,"error uploading file......" H 4 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPGPDPN"
.S V=$P(V,"|",2,9999)
.S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
.I N5]"" S ^BGPGPDPN(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPGPDPN(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPGPDPN(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPGPDPN(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPGPDPN(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPGPDPN(" D IX1^DIK
BY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90536.05,DIC="^BGPGPDBN(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 W !,"error uploading file......" H 4 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPGPDBN"
.S V=$P(V,"|",2,9999)
.S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
.I N5]"" S ^BGPGPDBN(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPGPDBN(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPGPDBN(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPGPDBN(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPGPDBN(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPGPDBN(" D IX1^DIK
W !,"Data uploaded."
D EOJ
Q
EOJ ;EP
L -^BGPGPDCN
L -^BGPGPDPN
L -^BGPGPDBN
L -^BGPHEDCN
L -^BGPHEDPN
L -^BGPHEDBN
L -^BGPELDCN
L -^BGPELDPN
L -^BGPELDBN
L -^BGPPEDCN
L -^BGPPEDPN
L -^BGPPEDBN
L -^BGPEOCN
L -^BGPEOPN
L -^BGPEOBN
D EOP^BGP9DH
K IOPAR
D HOME^%ZIS
K X,X1,X2,X3,X4,X5,X6
K A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
K N,N1,N2,N3,N4,N5,N6
K DIC,DA,X,Y,%Y,%,BGPJ,BGPX,BGPTEXT,BGPLINE,BGP
Q
STRIP(Z) ;REMOVE CONTROLL CHARACTERS
NEW I
F I=1:1:$L(Z) I (32>$A($E(Z,I))) S Z=$E(Z,1,I-1)_""_$E(Z,I+1,999)
Q Z
;
PROCHE ;
W !,"Processing",!
S BGP0=$P($G(^TMP("BGPUPL",$J,1,0)),"|",9)
S BGPG=$P($G(^TMP("BGPUPL",$J,1,0)),"|")
F X=1:1:14 S Y="BGP"_X,@Y=$P(BGP0,U,X)
;find existing entry and if exists, delete it
S (X,BGPOIEN)=0 F S X=$O(^BGPHEDCN(X)) Q:X'=+X D
.I '$D(^BGPHEDCN(X,0)) K ^BGPHEDCN(X) Q
.S Y=^BGPHEDCN(X,0)
.Q:$P(Y,U)'=BGP1
.Q:$P(Y,U,2)'=BGP2
.Q:$P(Y,U,3)'=BGP3
.Q:$P(Y,U,4)'=BGP4
.Q:$P(Y,U,5)'=BGP5
.Q:$P(Y,U,6)'=BGP6
.Q:$P(Y,U,8)'=BGP8
.Q:$P(Y,U,9)'=BGP9
.Q:$P(Y,U,10)'=BGP10
.Q:$P(Y,U,11)'=BGP11
.Q:$P(Y,U,12)'=BGP12
.Q:$P(Y,U,14)'=BGP14
.S BGPOIEN=X
D ^XBFMK
I BGPOIEN S DA=BGPOIEN,DIK="^BGPHEDCN(" D ^DIK S DA=BGPOIEN,DIK="^BGPHEDPN(" D ^DIK S DA=BGPOIEN,DIK="^BGPHEDBN(" D ^DIK
;add entry
L +^BGPHEDCN:10 I '$T W !!,"unable to lock global. TRY LATER" D EOJ Q
L +^BGPHEDPN:10 I '$T W !!,"unable to lock global. TRY LATER" D EOJ Q
L +^BGPHEDBN:10 I '$T W !!,"unable to lock global. TRY LATER" D EOJ Q
D GETIEN^BGP9HUTL
I 'BGPIEN W !!,"error in file creation...call programmer." D EOJ Q
HECY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90537.03,DIC="^BGPHEDCN(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 W !,"error uploading file......" H 4 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPHEDCN"
.S V=$P(V,"|",2,9999)
.S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
.I N5]"" S ^BGPHEDCN(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPHEDCN(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPHEDCN(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPHEDCN(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPHEDCN(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPHEDCN(" D IX1^DIK
HEPY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90537.04,DIC="^BGPHEDPN(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 W !,"error uploading file......" H 4 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPHEDPN"
.S V=$P(V,"|",2,9999)
.S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
.I N5]"" S ^BGPHEDPN(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPHEDPN(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPHEDPN(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPHEDPN(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPHEDPN(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPHEDPN(" D IX1^DIK
HEBY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90537.05,DIC="^BGPHEDBN(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 W !,"error uploading file......" H 4 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPHEDBN"
.S V=$P(V,"|",2,9999)
.S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
.I N5]"" S ^BGPHEDBN(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPHEDBN(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPHEDBN(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPHEDBN(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPHEDBN(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPHEDBN(" D IX1^DIK
W !,"Data uploaded."
D EOJ
Q
;
PROCEL ;
W !,"Processing",!
S BGP0=$P($G(^TMP("BGPUPL",$J,1,0)),"|",9)
S BGPG=$P($G(^TMP("BGPUPL",$J,1,0)),"|")
F X=1:1:14 S Y="BGP"_X,@Y=$P(BGP0,U,X)
;find existing entry and if exists, delete it
S (X,BGPOIEN)=0 F S X=$O(^BGPELDCN(X)) Q:X'=+X D
.I '$D(^BGPELDCN(X,0)) K ^BGPELDCN(X) Q
.S Y=^BGPELDCN(X,0)
.Q:$P(Y,U)'=BGP1
.Q:$P(Y,U,2)'=BGP2
.Q:$P(Y,U,3)'=BGP3
.Q:$P(Y,U,4)'=BGP4
.Q:$P(Y,U,5)'=BGP5
.Q:$P(Y,U,6)'=BGP6
.Q:$P(Y,U,8)'=BGP8
.Q:$P(Y,U,9)'=BGP9
.Q:$P(Y,U,10)'=BGP10
.Q:$P(Y,U,11)'=BGP11
.Q:$P(Y,U,12)'=BGP12
.Q:$P(Y,U,14)'=BGP14
.S BGPOIEN=X
D ^XBFMK
I BGPOIEN S DA=BGPOIEN,DIK="^BGPELDCN(" D ^DIK S DA=BGPOIEN,DIK="^BGPELDPN(" D ^DIK S DA=BGPOIEN,DIK="^BGPELDBN(" D ^DIK
;add entry
L +^BGPELDCN:10 I '$T W !!,"unable to lock global. TRY LATER" D EOJ Q
L +^BGPELDPN:10 I '$T W !!,"unable to lock global. TRY LATER" D EOJ Q
L +^BGPELDBN:10 I '$T W !!,"unable to lock global. TRY LATER" D EOJ Q
D GETIEN^BGP9EUTL
I 'BGPIEN W !!,"error in file creation...call programmer." D EOJ Q
ELCY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90537.03,DIC="^BGPELDCN(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 W !,"error uploading file......" H 4 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPELDCN"
.S V=$P(V,"|",2,9999)
.S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
.I N5]"" S ^BGPELDCN(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPELDCN(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPELDCN(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPELDCN(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPELDCN(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPELDCN(" D IX1^DIK
ELPY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90537.04,DIC="^BGPELDPN(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 W !,"error uploading file......" H 4 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPELDPN"
.S V=$P(V,"|",2,9999)
.S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
.I N5]"" S ^BGPELDPN(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPELDPN(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPELDPN(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPELDPN(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPELDPN(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPELDPN(" D IX1^DIK
ELBY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90537.05,DIC="^BGPELDBN(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 W !,"error uploading file......" H 4 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPELDBN"
.S V=$P(V,"|",2,9999)
.S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
.I N5]"" S ^BGPELDBN(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPELDBN(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPELDBN(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPELDBN(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPELDBN(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPELDBN(" D IX1^DIK
W !,"Data uploaded."
D EOJ
Q
;
PROCPED ;
W !,"Processing",!
S BGP0=$P($G(^TMP("BGPUPL",$J,1,0)),"|",9)
S BGPG=$P($G(^TMP("BGPUPL",$J,1,0)),"|")
F X=1:1:14 S Y="BGP"_X,@Y=$P(BGP0,U,X)
;find existing entry and if exists, delete it
S (X,BGPOIEN)=0 F S X=$O(^BGPPEDCN(X)) Q:X'=+X D
.I '$D(^BGPPEDCN(X,0)) K ^BGPPEDCN(X) Q
.S Y=^BGPPEDCN(X,0)
.Q:$P(Y,U)'=BGP1
.Q:$P(Y,U,2)'=BGP2
.Q:$P(Y,U,3)'=BGP3
.Q:$P(Y,U,4)'=BGP4
.Q:$P(Y,U,5)'=BGP5
.Q:$P(Y,U,6)'=BGP6
.Q:$P(Y,U,7)'=BGP7
.Q:$P(Y,U,8)'=BGP8
.Q:$P(Y,U,9)'=BGP9
.Q:$P(Y,U,10)'=BGP10
.Q:$P(Y,U,11)'=BGP11
.Q:$P(Y,U,12)'=BGP12
.S BGPOIEN=X
D ^XBFMK
I BGPOIEN S DA=BGPOIEN,DIK="^BGPPEDCN(" D ^DIK S DA=BGPOIEN,DIK="^BGPPEDPN(" D ^DIK S DA=BGPOIEN,DIK="^BGPPEDBN(" D ^DIK
;add entry
L +^BGPPEDCN:10 I '$T W !!,"unable to lock global. TRY LATER" D EOJ Q
L +^BGPPEDPN:10 I '$T W !!,"unable to lock global. TRY LATER" D EOJ Q
L +^BGPPEDBN:10 I '$T W !!,"unable to lock global. TRY LATER" D EOJ Q
D GETIEN^BGP9PUTL
I 'BGPIEN W !!,"error in file creation...call programmer." D EOJ Q
PEDCY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90536.12,DIC="^BGPPEDCN(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 W !,"error uploading file......" H 4 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPPEDCN"
.S V=$P(V,"|",2,9999)
.S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
.I N5]"" S ^BGPPEDCN(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPPEDCN(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPPEDCN(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPPEDCN(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPPEDCN(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPPEDCN(" D IX1^DIK
PEDPY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90536.13,DIC="^BGPPEDPN(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 W !,"error uploading file......" H 4 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPPEDPN"
.S V=$P(V,"|",2,9999)
.S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
.I N5]"" S ^BGPPEDPN(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPPEDPN(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPPEDPN(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPPEDPN(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPPEDPN(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPPEDPN(" D IX1^DIK
PEDBY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90536.14,DIC="^BGPPEDBN(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 W !,"error uploading file......" H 4 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPPEDBN"
.S V=$P(V,"|",2,9999)
.S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
.I N5]"" S ^BGPPEDBN(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPPEDBN(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPPEDBN(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPPEDBN(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPPEDBN(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPPEDBN(" D IX1^DIK
W !,"Data uploaded."
D EOJ
Q
BGP9ULF ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 27 May 2009 4:26 PM ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+2 ;
+3 ;
+4 IF $DATA(IOF)
WRITE @IOF
+5 WRITE !,"This option is used to upload a SU's 2009 CRS data.",!,"You must specify the directory in which the CRS 2009 data file resides",!,"and then enter the filename of the data.",!
FILE ;
+1 DO HOME^%ZIS
DIR ;
+1 KILL DIR
+2 SET BGPDIR=""
+3 SET DIR(0)="FO^3:50"
SET DIR("A")="Enter directory path (i.e. /usr/spool/uucppublic/)"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
WRITE !!,"Directory not entered!! Bye."
GOTO EOJ
+5 IF Y=""
WRITE !!,"Directory not entered!! Bye."
GOTO EOJ
+6 SET BGPDIR=Y
FILENAME ;
+1 WRITE !!
+2 SET BGPFILE=""
+3 SET DIR(0)="FO^2:30"
SET DIR("A")="Enter filename w /ext (i.e. BG09101201.5)"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO DIR
+5 IF Y=""
GOTO DIR
+6 IF $EXTRACT($$UP^XLFSTR(Y),1,4)'="BG09"
WRITE !!,"Filename must begin with BG09"
GOTO FILENAME
+7 SET BGPFILE=Y
+8 WRITE !,"Directory=",BGPDIR," ","File=",BGPFILE
+9 DO READF
+10 GOTO FILENAME
READF ;EP read file
+1 NEW Y,X,I,BGPC
+2 SET BGPC=1
+3 SET Y=$$OPEN^%ZISH(BGPDIR,BGPFILE,"R")
+4 IF Y
WRITE !,*7,"CANNOT OPEN (OR ACCESS) FILE '",BGPDIR,BGPFILE,"'."
GOTO EOJ
+5 KILL ^TMP("BGPUPL",$JOB)
+6 FOR I=1:1
USE IO
READ X:DTIME
SET X=$$STRIP(X)
IF X=""
QUIT
SET ^TMP("BGPUPL",$JOB,BGPC,0)=X
SET BGPC=BGPC+1
IF $$STATUS^%ZISH=-1
QUIT
+7 DO ^%ZISC
+8 WRITE !!,"All done reading file",!
PROC ;
+1 IF $PIECE(BGPFILE,".",2)["HE"
DO PROCHE
QUIT
+2 IF $PIECE(BGPFILE,".",2)["EL"
DO PROCEL
QUIT
+3 IF $PIECE(BGPFILE,".",2)["PED"
DO PROCPED
QUIT
+4 IF $PIECE(BGPFILE,".",2)["EO"
DO PROCEO^BGP9ULF1
QUIT
+5 ;I $P(BGPFILE,".",2)["ON" D PROCON Q
+6 WRITE !,"Processing",!
+7 SET BGP0=$PIECE($GET(^TMP("BGPUPL",$JOB,1,0)),"|",9)
+8 SET BGPG=$PIECE($GET(^TMP("BGPUPL",$JOB,1,0)),"|")
+9 FOR X=1:1:14
SET Y="BGP"_X
SET @Y=$PIECE(BGP0,U,X)
+10 ;find existing entry and if exists, delete it
+11 SET (X,BGPOIEN)=0
FOR
SET X=$ORDER(^BGPGPDCN(X))
IF X'=+X
QUIT
Begin DoDot:1
+12 IF '$DATA(^BGPGPDCN(X,0))
KILL ^BGPGPDCN(X)
QUIT
+13 SET Y=^BGPGPDCN(X,0)
+14 IF $PIECE(Y,U)'=BGP1
QUIT
+15 IF $PIECE(Y,U,2)'=BGP2
QUIT
+16 IF $PIECE(Y,U,3)'=BGP3
QUIT
+17 IF $PIECE(Y,U,4)'=BGP4
QUIT
+18 IF $PIECE(Y,U,5)'=BGP5
QUIT
+19 IF $PIECE(Y,U,6)'=BGP6
QUIT
+20 IF $PIECE(Y,U,8)'=BGP8
QUIT
+21 IF $PIECE(Y,U,9)'=BGP9
QUIT
+22 IF $PIECE(Y,U,10)'=BGP10
QUIT
+23 IF $PIECE(Y,U,11)'=BGP11
QUIT
+24 IF $PIECE(Y,U,12)'=BGP12
QUIT
+25 IF $PIECE(Y,U,14)'=BGP14
QUIT
+26 SET BGPOIEN=X
End DoDot:1
+27 DO ^XBFMK
+28 IF BGPOIEN
SET DA=BGPOIEN
SET DIK="^BGPGPDCN("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPGPDPN("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPGPDBN("
DO ^DIK
+29 ;add entry
+30 LOCK +^BGPGPDCN:10
IF '$TEST
WRITE !!,"unable to lock global. TRY LATER"
DO EOJ
QUIT
+31 LOCK +^BGPGPDPN:10
IF '$TEST
WRITE !!,"unable to lock global. TRY LATER"
DO EOJ
QUIT
+32 LOCK +^BGPGPDBN:10
IF '$TEST
WRITE !!,"unable to lock global. TRY LATER"
DO EOJ
QUIT
+33 DO GETIEN^BGP9UTL
+34 IF 'BGPIEN
WRITE !!,"error in file creation...call programmer."
DO EOJ
QUIT
CY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90536.03
SET DIC="^BGPGPDCN("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
WRITE !,"error uploading file......"
HANG 4
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPGPDCN"
QUIT
+9 SET V=$PIECE(V,"|",2,9999)
+10 SET N=$PIECE(V,"|")
SET N2=$PIECE(V,"|",2)
SET N3=$PIECE(V,"|",3)
SET N4=$PIECE(V,"|",4)
SET N5=$PIECE(V,"|",5)
SET D=$PIECE(V,"|",8)
+11 IF N5]""
SET ^BGPGPDCN(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPGPDCN(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPGPDCN(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPGPDCN(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPGPDCN(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPGPDCN("
DO IX1^DIK
PY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90536.04
SET DIC="^BGPGPDPN("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
WRITE !,"error uploading file......"
HANG 4
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPGPDPN"
QUIT
+9 SET V=$PIECE(V,"|",2,9999)
+10 SET N=$PIECE(V,"|")
SET N2=$PIECE(V,"|",2)
SET N3=$PIECE(V,"|",3)
SET N4=$PIECE(V,"|",4)
SET N5=$PIECE(V,"|",5)
SET D=$PIECE(V,"|",8)
+11 IF N5]""
SET ^BGPGPDPN(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPGPDPN(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPGPDPN(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPGPDPN(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPGPDPN(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPGPDPN("
DO IX1^DIK
BY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90536.05
SET DIC="^BGPGPDBN("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
WRITE !,"error uploading file......"
HANG 4
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPGPDBN"
QUIT
+9 SET V=$PIECE(V,"|",2,9999)
+10 SET N=$PIECE(V,"|")
SET N2=$PIECE(V,"|",2)
SET N3=$PIECE(V,"|",3)
SET N4=$PIECE(V,"|",4)
SET N5=$PIECE(V,"|",5)
SET D=$PIECE(V,"|",8)
+11 IF N5]""
SET ^BGPGPDBN(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPGPDBN(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPGPDBN(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPGPDBN(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPGPDBN(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPGPDBN("
DO IX1^DIK
+18 WRITE !,"Data uploaded."
+19 DO EOJ
+20 QUIT
EOJ ;EP
+1 LOCK -^BGPGPDCN
+2 LOCK -^BGPGPDPN
+3 LOCK -^BGPGPDBN
+4 LOCK -^BGPHEDCN
+5 LOCK -^BGPHEDPN
+6 LOCK -^BGPHEDBN
+7 LOCK -^BGPELDCN
+8 LOCK -^BGPELDPN
+9 LOCK -^BGPELDBN
+10 LOCK -^BGPPEDCN
+11 LOCK -^BGPPEDPN
+12 LOCK -^BGPPEDBN
+13 LOCK -^BGPEOCN
+14 LOCK -^BGPEOPN
+15 LOCK -^BGPEOBN
+16 DO EOP^BGP9DH
+17 KILL IOPAR
+18 DO HOME^%ZIS
+19 KILL X,X1,X2,X3,X4,X5,X6
+20 KILL A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
+21 KILL N,N1,N2,N3,N4,N5,N6
+22 KILL DIC,DA,X,Y,%Y,%,BGPJ,BGPX,BGPTEXT,BGPLINE,BGP
+23 QUIT
STRIP(Z) ;REMOVE CONTROLL CHARACTERS
+1 NEW I
+2 FOR I=1:1:$LENGTH(Z)
IF (32>$ASCII($EXTRACT(Z,I)))
SET Z=$EXTRACT(Z,1,I-1)_""_$EXTRACT(Z,I+1,999)
+3 QUIT Z
+4 ;
PROCHE ;
+1 WRITE !,"Processing",!
+2 SET BGP0=$PIECE($GET(^TMP("BGPUPL",$JOB,1,0)),"|",9)
+3 SET BGPG=$PIECE($GET(^TMP("BGPUPL",$JOB,1,0)),"|")
+4 FOR X=1:1:14
SET Y="BGP"_X
SET @Y=$PIECE(BGP0,U,X)
+5 ;find existing entry and if exists, delete it
+6 SET (X,BGPOIEN)=0
FOR
SET X=$ORDER(^BGPHEDCN(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 IF '$DATA(^BGPHEDCN(X,0))
KILL ^BGPHEDCN(X)
QUIT
+8 SET Y=^BGPHEDCN(X,0)
+9 IF $PIECE(Y,U)'=BGP1
QUIT
+10 IF $PIECE(Y,U,2)'=BGP2
QUIT
+11 IF $PIECE(Y,U,3)'=BGP3
QUIT
+12 IF $PIECE(Y,U,4)'=BGP4
QUIT
+13 IF $PIECE(Y,U,5)'=BGP5
QUIT
+14 IF $PIECE(Y,U,6)'=BGP6
QUIT
+15 IF $PIECE(Y,U,8)'=BGP8
QUIT
+16 IF $PIECE(Y,U,9)'=BGP9
QUIT
+17 IF $PIECE(Y,U,10)'=BGP10
QUIT
+18 IF $PIECE(Y,U,11)'=BGP11
QUIT
+19 IF $PIECE(Y,U,12)'=BGP12
QUIT
+20 IF $PIECE(Y,U,14)'=BGP14
QUIT
+21 SET BGPOIEN=X
End DoDot:1
+22 DO ^XBFMK
+23 IF BGPOIEN
SET DA=BGPOIEN
SET DIK="^BGPHEDCN("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPHEDPN("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPHEDBN("
DO ^DIK
+24 ;add entry
+25 LOCK +^BGPHEDCN:10
IF '$TEST
WRITE !!,"unable to lock global. TRY LATER"
DO EOJ
QUIT
+26 LOCK +^BGPHEDPN:10
IF '$TEST
WRITE !!,"unable to lock global. TRY LATER"
DO EOJ
QUIT
+27 LOCK +^BGPHEDBN:10
IF '$TEST
WRITE !!,"unable to lock global. TRY LATER"
DO EOJ
QUIT
+28 DO GETIEN^BGP9HUTL
+29 IF 'BGPIEN
WRITE !!,"error in file creation...call programmer."
DO EOJ
QUIT
HECY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90537.03
SET DIC="^BGPHEDCN("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
WRITE !,"error uploading file......"
HANG 4
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPHEDCN"
QUIT
+9 SET V=$PIECE(V,"|",2,9999)
+10 SET N=$PIECE(V,"|")
SET N2=$PIECE(V,"|",2)
SET N3=$PIECE(V,"|",3)
SET N4=$PIECE(V,"|",4)
SET N5=$PIECE(V,"|",5)
SET D=$PIECE(V,"|",8)
+11 IF N5]""
SET ^BGPHEDCN(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPHEDCN(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPHEDCN(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPHEDCN(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPHEDCN(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPHEDCN("
DO IX1^DIK
HEPY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90537.04
SET DIC="^BGPHEDPN("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
WRITE !,"error uploading file......"
HANG 4
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPHEDPN"
QUIT
+9 SET V=$PIECE(V,"|",2,9999)
+10 SET N=$PIECE(V,"|")
SET N2=$PIECE(V,"|",2)
SET N3=$PIECE(V,"|",3)
SET N4=$PIECE(V,"|",4)
SET N5=$PIECE(V,"|",5)
SET D=$PIECE(V,"|",8)
+11 IF N5]""
SET ^BGPHEDPN(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPHEDPN(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPHEDPN(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPHEDPN(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPHEDPN(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPHEDPN("
DO IX1^DIK
HEBY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90537.05
SET DIC="^BGPHEDBN("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
WRITE !,"error uploading file......"
HANG 4
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPHEDBN"
QUIT
+9 SET V=$PIECE(V,"|",2,9999)
+10 SET N=$PIECE(V,"|")
SET N2=$PIECE(V,"|",2)
SET N3=$PIECE(V,"|",3)
SET N4=$PIECE(V,"|",4)
SET N5=$PIECE(V,"|",5)
SET D=$PIECE(V,"|",8)
+11 IF N5]""
SET ^BGPHEDBN(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPHEDBN(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPHEDBN(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPHEDBN(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPHEDBN(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPHEDBN("
DO IX1^DIK
+18 WRITE !,"Data uploaded."
+19 DO EOJ
+20 QUIT
+21 ;
PROCEL ;
+1 WRITE !,"Processing",!
+2 SET BGP0=$PIECE($GET(^TMP("BGPUPL",$JOB,1,0)),"|",9)
+3 SET BGPG=$PIECE($GET(^TMP("BGPUPL",$JOB,1,0)),"|")
+4 FOR X=1:1:14
SET Y="BGP"_X
SET @Y=$PIECE(BGP0,U,X)
+5 ;find existing entry and if exists, delete it
+6 SET (X,BGPOIEN)=0
FOR
SET X=$ORDER(^BGPELDCN(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 IF '$DATA(^BGPELDCN(X,0))
KILL ^BGPELDCN(X)
QUIT
+8 SET Y=^BGPELDCN(X,0)
+9 IF $PIECE(Y,U)'=BGP1
QUIT
+10 IF $PIECE(Y,U,2)'=BGP2
QUIT
+11 IF $PIECE(Y,U,3)'=BGP3
QUIT
+12 IF $PIECE(Y,U,4)'=BGP4
QUIT
+13 IF $PIECE(Y,U,5)'=BGP5
QUIT
+14 IF $PIECE(Y,U,6)'=BGP6
QUIT
+15 IF $PIECE(Y,U,8)'=BGP8
QUIT
+16 IF $PIECE(Y,U,9)'=BGP9
QUIT
+17 IF $PIECE(Y,U,10)'=BGP10
QUIT
+18 IF $PIECE(Y,U,11)'=BGP11
QUIT
+19 IF $PIECE(Y,U,12)'=BGP12
QUIT
+20 IF $PIECE(Y,U,14)'=BGP14
QUIT
+21 SET BGPOIEN=X
End DoDot:1
+22 DO ^XBFMK
+23 IF BGPOIEN
SET DA=BGPOIEN
SET DIK="^BGPELDCN("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPELDPN("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPELDBN("
DO ^DIK
+24 ;add entry
+25 LOCK +^BGPELDCN:10
IF '$TEST
WRITE !!,"unable to lock global. TRY LATER"
DO EOJ
QUIT
+26 LOCK +^BGPELDPN:10
IF '$TEST
WRITE !!,"unable to lock global. TRY LATER"
DO EOJ
QUIT
+27 LOCK +^BGPELDBN:10
IF '$TEST
WRITE !!,"unable to lock global. TRY LATER"
DO EOJ
QUIT
+28 DO GETIEN^BGP9EUTL
+29 IF 'BGPIEN
WRITE !!,"error in file creation...call programmer."
DO EOJ
QUIT
ELCY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90537.03
SET DIC="^BGPELDCN("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
WRITE !,"error uploading file......"
HANG 4
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPELDCN"
QUIT
+9 SET V=$PIECE(V,"|",2,9999)
+10 SET N=$PIECE(V,"|")
SET N2=$PIECE(V,"|",2)
SET N3=$PIECE(V,"|",3)
SET N4=$PIECE(V,"|",4)
SET N5=$PIECE(V,"|",5)
SET D=$PIECE(V,"|",8)
+11 IF N5]""
SET ^BGPELDCN(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPELDCN(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPELDCN(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPELDCN(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPELDCN(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPELDCN("
DO IX1^DIK
ELPY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90537.04
SET DIC="^BGPELDPN("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
WRITE !,"error uploading file......"
HANG 4
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPELDPN"
QUIT
+9 SET V=$PIECE(V,"|",2,9999)
+10 SET N=$PIECE(V,"|")
SET N2=$PIECE(V,"|",2)
SET N3=$PIECE(V,"|",3)
SET N4=$PIECE(V,"|",4)
SET N5=$PIECE(V,"|",5)
SET D=$PIECE(V,"|",8)
+11 IF N5]""
SET ^BGPELDPN(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPELDPN(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPELDPN(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPELDPN(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPELDPN(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPELDPN("
DO IX1^DIK
ELBY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90537.05
SET DIC="^BGPELDBN("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
WRITE !,"error uploading file......"
HANG 4
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPELDBN"
QUIT
+9 SET V=$PIECE(V,"|",2,9999)
+10 SET N=$PIECE(V,"|")
SET N2=$PIECE(V,"|",2)
SET N3=$PIECE(V,"|",3)
SET N4=$PIECE(V,"|",4)
SET N5=$PIECE(V,"|",5)
SET D=$PIECE(V,"|",8)
+11 IF N5]""
SET ^BGPELDBN(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPELDBN(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPELDBN(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPELDBN(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPELDBN(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPELDBN("
DO IX1^DIK
+18 WRITE !,"Data uploaded."
+19 DO EOJ
+20 QUIT
+21 ;
PROCPED ;
+1 WRITE !,"Processing",!
+2 SET BGP0=$PIECE($GET(^TMP("BGPUPL",$JOB,1,0)),"|",9)
+3 SET BGPG=$PIECE($GET(^TMP("BGPUPL",$JOB,1,0)),"|")
+4 FOR X=1:1:14
SET Y="BGP"_X
SET @Y=$PIECE(BGP0,U,X)
+5 ;find existing entry and if exists, delete it
+6 SET (X,BGPOIEN)=0
FOR
SET X=$ORDER(^BGPPEDCN(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 IF '$DATA(^BGPPEDCN(X,0))
KILL ^BGPPEDCN(X)
QUIT
+8 SET Y=^BGPPEDCN(X,0)
+9 IF $PIECE(Y,U)'=BGP1
QUIT
+10 IF $PIECE(Y,U,2)'=BGP2
QUIT
+11 IF $PIECE(Y,U,3)'=BGP3
QUIT
+12 IF $PIECE(Y,U,4)'=BGP4
QUIT
+13 IF $PIECE(Y,U,5)'=BGP5
QUIT
+14 IF $PIECE(Y,U,6)'=BGP6
QUIT
+15 IF $PIECE(Y,U,7)'=BGP7
QUIT
+16 IF $PIECE(Y,U,8)'=BGP8
QUIT
+17 IF $PIECE(Y,U,9)'=BGP9
QUIT
+18 IF $PIECE(Y,U,10)'=BGP10
QUIT
+19 IF $PIECE(Y,U,11)'=BGP11
QUIT
+20 IF $PIECE(Y,U,12)'=BGP12
QUIT
+21 SET BGPOIEN=X
End DoDot:1
+22 DO ^XBFMK
+23 IF BGPOIEN
SET DA=BGPOIEN
SET DIK="^BGPPEDCN("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPPEDPN("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPPEDBN("
DO ^DIK
+24 ;add entry
+25 LOCK +^BGPPEDCN:10
IF '$TEST
WRITE !!,"unable to lock global. TRY LATER"
DO EOJ
QUIT
+26 LOCK +^BGPPEDPN:10
IF '$TEST
WRITE !!,"unable to lock global. TRY LATER"
DO EOJ
QUIT
+27 LOCK +^BGPPEDBN:10
IF '$TEST
WRITE !!,"unable to lock global. TRY LATER"
DO EOJ
QUIT
+28 DO GETIEN^BGP9PUTL
+29 IF 'BGPIEN
WRITE !!,"error in file creation...call programmer."
DO EOJ
QUIT
PEDCY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90536.12
SET DIC="^BGPPEDCN("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
WRITE !,"error uploading file......"
HANG 4
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPPEDCN"
QUIT
+9 SET V=$PIECE(V,"|",2,9999)
+10 SET N=$PIECE(V,"|")
SET N2=$PIECE(V,"|",2)
SET N3=$PIECE(V,"|",3)
SET N4=$PIECE(V,"|",4)
SET N5=$PIECE(V,"|",5)
SET D=$PIECE(V,"|",8)
+11 IF N5]""
SET ^BGPPEDCN(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPPEDCN(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPPEDCN(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPPEDCN(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPPEDCN(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPPEDCN("
DO IX1^DIK
PEDPY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90536.13
SET DIC="^BGPPEDPN("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
WRITE !,"error uploading file......"
HANG 4
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPPEDPN"
QUIT
+9 SET V=$PIECE(V,"|",2,9999)
+10 SET N=$PIECE(V,"|")
SET N2=$PIECE(V,"|",2)
SET N3=$PIECE(V,"|",3)
SET N4=$PIECE(V,"|",4)
SET N5=$PIECE(V,"|",5)
SET D=$PIECE(V,"|",8)
+11 IF N5]""
SET ^BGPPEDPN(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPPEDPN(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPPEDPN(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPPEDPN(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPPEDPN(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPPEDPN("
DO IX1^DIK
PEDBY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90536.14
SET DIC="^BGPPEDBN("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
WRITE !,"error uploading file......"
HANG 4
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPPEDBN"
QUIT
+9 SET V=$PIECE(V,"|",2,9999)
+10 SET N=$PIECE(V,"|")
SET N2=$PIECE(V,"|",2)
SET N3=$PIECE(V,"|",3)
SET N4=$PIECE(V,"|",4)
SET N5=$PIECE(V,"|",5)
SET D=$PIECE(V,"|",8)
+11 IF N5]""
SET ^BGPPEDBN(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPPEDBN(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPPEDBN(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPPEDBN(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPPEDBN(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPPEDBN("
DO IX1^DIK
+18 WRITE !,"Data uploaded."
+19 DO EOJ
+20 QUIT
