- BGP1GUPL ; IHS/CMI/LAB - GUI Upload ;
- ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
- ;
- ;
- EP(BGPRET,BGPUSER,BGPDUZ2,BGPOPTN,BGPDIR,BGPFILE,BGPRTIME) ;EP - called from GUI to produce COM REPORT CI05-AO-UPL
- ; SEE ROUTINE BGP1DL if you have questions about any of these variables
- ; BGPUSER - DUZ
- ; BGPDUZ2 - DUZ(2)
- ; BGPOPTN - OPTION NAME
- ; BGPFILE - FILE TO UPLOAD
- ;
- ;
- ; BGPRET - return value is ien^error message. a zero (0) is
- ; passed as ien if error occurred, display the filename back to the user
- ; if they chose to export to area
- ;
- ; I put the list of files in the BGPGUIB global in field 1100 as an output
- ;create entry in gui output file
- ;queue report to run with/GUIR
- D EP1
- S Y=$G(BGPRET)
- ;D EN^XBVK("BGP") S:$D(ZTQUEUED) ZTREQ="@"
- I '$P($G(BGPRET),U) S BGPRET=1_"^Upload OK"
- Q
- EP1 ;
- S U="^"
- I $G(BGPUSER)="" S BGPRET=0_"^USER NOT PASSED" Q
- I $G(BGPDUZ2)="" S BGPRET=0_"^DUZ(2) NOT PASSED" Q
- I $G(BGPOPTN)="" S BGPRET=0_"^OPTION NAME NOT PASSED" Q
- I $G(BGPDIR)="" S BGPRET=0_"^DIRECTORY NAME NOT PASSED" Q
- I $G(BGPFILE)="" S BGPRET=0_"^FILE NAME NOT PASSED" Q
- S BGPRTIME=$G(BGPRTIME)
- ;S DUZ=BGPUSER
- S DUZ(2)=BGPDUZ2
- S:'$D(DT) DT=$$DT^XLFDT
- D ^XBKVAR
- S BGPGUI=1
- S IOM=80,BGPIOSL=55
- ;SEND THE REPORT PROCESS OFF TO THE BACKGROUND USING TASKMAN CALL
- AOUPL ;
- READF ;EP read file
- NEW Y,X,I,BGPC
- S BGPC=1
- S Y=$$OPEN^%ZISH(BGPDIR,BGPFILE,"R")
- I Y S BGPRET="0^CANNOT OPEN (OR ACCESS) FILE '"_BGPDIR_BGPFILE_"'." D EOJ Q
- 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^BGP1GUP1 Q
- ;W !,"Processing",!
- S BGP1=$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(BGP1,U,X)
- ;find existing entry and if exists, delete it
- N X
- S (X,BGPOIEN)=0 F S X=$O(^BGPGPDCB(X)) Q:X'=+X D
- .Q:'$D(^BGPGPDCB(X,0))
- .S Y=^BGPGPDCB(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="^BGPGPDCB(" D ^DIK S DA=BGPOIEN,DIK="^BGPGPDPB(" D ^DIK S DA=BGPOIEN,DIK="^BGPGPDBB(" D ^DIK
- ;add entry
- L +^BGPGPDCB:10 I '$T S BGPRET=0_"^unable to lock global. TRY LATER" D EOJ Q
- L +^BGPGPDPB:10 I '$T S BGPRET=0_"^unable to lock global. TRY LATER" D EOJ Q
- L +^BGPGPDBB:10 I '$T S BGPRET=0_"^unable to lock global. TRY LATER" D EOJ Q
- D GETIEN^BGP1UTL
- I 'BGPIEN S BGPRET=0_"^error in file creation...call programmer." D EOJ Q
- CY ;
- S DINUM=BGPIEN,X=$P(BGP1,U),DLAYGO=90545.03,DIC="^BGPGPDCB(",DIC(0)="L"
- K DD,D0,DO
- D FILE^DICN
- I Y=-1 S BGPRET=0_"^error uploading file......" 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,"|")'="BGPGPDCB"
- .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 ^BGPGPDCB(BGPIEN,N,N2,N3,N4,N5)=D Q
- .I N4]"" S ^BGPGPDCB(BGPIEN,N,N2,N3,N4)=D Q
- .I N3]"" S ^BGPGPDCB(BGPIEN,N,N2,N3)=D Q
- .I N2]"" S ^BGPGPDCB(BGPIEN,N,N2)=D Q
- .I N]"" S ^BGPGPDCB(BGPIEN,N)=D
- .Q
- S DA=BGPIEN,DIK="^BGPGPDCB(" D IX1^DIK
- PY ;
- S DINUM=BGPIEN,X=$P(BGP1,U),DLAYGO=90545.04,DIC="^BGPGPDPB(",DIC(0)="L"
- K DD,D0,DO
- D FILE^DICN
- I Y=-1 S BGPRET=0_"^error uploading file......" 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,"|")'="BGPGPDPB"
- .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 ^BGPGPDPB(BGPIEN,N,N2,N3,N4,N5)=D Q
- .I N4]"" S ^BGPGPDPB(BGPIEN,N,N2,N3,N4)=D Q
- .I N3]"" S ^BGPGPDPB(BGPIEN,N,N2,N3)=D Q
- .I N2]"" S ^BGPGPDPB(BGPIEN,N,N2)=D Q
- .I N]"" S ^BGPGPDPB(BGPIEN,N)=D
- .Q
- S DA=BGPIEN,DIK="^BGPGPDPB(" D IX1^DIK
- BY ;
- S DINUM=BGPIEN,X=$P(BGP1,U),DLAYGO=90545.05,DIC="^BGPGPDBB(",DIC(0)="L"
- K DD,D0,DO
- D FILE^DICN
- I Y=-1 S BGPRET=0_"^error uploading file......" 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,"|")'="BGPGPDBB"
- .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 ^BGPGPDBB(BGPIEN,N,N2,N3,N4,N5)=D Q
- .I N4]"" S ^BGPGPDBB(BGPIEN,N,N2,N3,N4)=D Q
- .I N3]"" S ^BGPGPDBB(BGPIEN,N,N2,N3)=D Q
- .I N2]"" S ^BGPGPDBB(BGPIEN,N,N2)=D Q
- .I N]"" S ^BGPGPDBB(BGPIEN,N)=D
- .Q
- S DA=BGPIEN,DIK="^BGPGPDBB(" D IX1^DIK
- ;W !,"Data uploaded."
- D EOJ
- Q
- EOJ ;EP
- L -^BGPGPDCB
- L -^BGPGPDPB
- L -^BGPGPDBB
- L -^BGPHEDCB
- L -^BGPHEDPB
- L -^BGPHEDBB
- L -^BGPELDCB
- L -^BGPELDPB
- L -^BGPELDBB
- L -^BGPPEDCB
- L -^BGPPEDPB
- L -^BGPPEDBB
- L -^BGPEOCB
- L -^BGPEOBB
- L -^BGPEOPB
- ;D EOP^BGP1DH
- 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,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 BGP1=$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(BGP1,U,X)
- ;find existing entry and if exists, delete it
- N X
- S (X,BGPOIEN)=0 F S X=$O(^BGPHEDCB(X)) Q:X'=+X S Y=^BGPHEDCB(X,0) D
- .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="^BGPHEDCB(" D ^DIK S DA=BGPOIEN,DIK="^BGPHEDPB(" D ^DIK S DA=BGPOIEN,DIK="^BGPHEDBB(" D ^DIK
- ;add entry
- L +^BGPHEDCB:10 I '$T S BGPRET=0_"^unable to lock global. TRY LATER" D EOJ Q
- L +^BGPHEDPB:10 I '$T S BGPRET=0_"^unable to lock global. TRY LATER" D EOJ Q
- L +^BGPHEDBB:10 I '$T S BGPRET=0_"^unable to lock global. TRY LATER" D EOJ Q
- D GETIEN^BGP1HUTL
- I 'BGPIEN S BGPRET=0_"^error in file creation...call programmer." D EOJ Q
- HECY ;
- S DINUM=BGPIEN,X=$P(BGP1,U),DLAYGO=90546.03,DIC="^BGPHEDCB(",DIC(0)="L"
- K DD,D0,DO
- D FILE^DICN
- I Y=-1 S BGPRET=0_"^error uploading file......" G EOJ
- S BGPIEN=+Y
- D ^XBFMK
- N X
- 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,"|")'="BGPHEDCB"
- .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 ^BGPHEDCB(BGPIEN,N,N2,N3,N4,N5)=D Q
- .I N4]"" S ^BGPHEDCB(BGPIEN,N,N2,N3,N4)=D Q
- .I N3]"" S ^BGPHEDCB(BGPIEN,N,N2,N3)=D Q
- .I N2]"" S ^BGPHEDCB(BGPIEN,N,N2)=D Q
- .I N]"" S ^BGPHEDCB(BGPIEN,N)=D
- .Q
- S DA=BGPIEN,DIK="^BGPHEDCB(" D IX1^DIK
- HEPY ;
- S DINUM=BGPIEN,X=$P(BGP1,U),DLAYGO=90546.04,DIC="^BGPHEDPB(",DIC(0)="L"
- K DD,D0,DO
- D FILE^DICN
- I Y=-1 S BGPRET=0_"^error uploading file......" G EOJ
- S BGPIEN=+Y
- D ^XBFMK
- N X
- 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,"|")'="BGPHEDPB"
- .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 ^BGPHEDPB(BGPIEN,N,N2,N3,N4,N5)=D Q
- .I N4]"" S ^BGPHEDPB(BGPIEN,N,N2,N3,N4)=D Q
- .I N3]"" S ^BGPHEDPB(BGPIEN,N,N2,N3)=D Q
- .I N2]"" S ^BGPHEDPB(BGPIEN,N,N2)=D Q
- .I N]"" S ^BGPHEDPB(BGPIEN,N)=D
- .Q
- S DA=BGPIEN,DIK="^BGPHEDPB(" D IX1^DIK
HEBY ;
S DINUM=BGPIEN,X=$P(BGP1,U),DLAYGO=90546.05,DIC="^BGPHEDBB(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 S BGPRET=0_"^error uploading file......" 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,"|")'="BGPHEDBB"
.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 ^BGPHEDBB(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPHEDBB(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPHEDBB(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPHEDBB(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPHEDBB(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPHEDBB(" D IX1^DIK
;W !,"Data uploaded."
D EOJ
Q
;
PROCEL ;
;W !,"Processing",!
S BGP1=$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(BGP1,U,X)
;find existing entry and if exists, delete it
N X
S (X,BGPOIEN)=0 F S X=$O(^BGPELDCB(X)) Q:X'=+X S Y=^BGPELDCB(X,0) D
.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="^BGPELDCB(" D ^DIK S DA=BGPOIEN,DIK="^BGPELDPB(" D ^DIK S DA=BGPOIEN,DIK="^BGPELDBB(" D ^DIK
;add entry
L +^BGPELDCB:10 I '$T S BGPRET=0_"^unable to lock global. TRY LATER" D EOJ Q
L +^BGPELDPB:10 I '$T S BGPRET=0_"^unable to lock global. TRY LATER" D EOJ Q
L +^BGPELDBB:10 I '$T S BGPRET=0_"^unable to lock global. TRY LATER" D EOJ Q
D GETIEN^BGP1EUTL
I 'BGPIEN S BGPRET=0_"^error in file creation...call programmer." D EOJ Q
ELCY ;
S DINUM=BGPIEN,X=$P(BGP1,U),DLAYGO=90547.03,DIC="^BGPELDCB(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 S BGPRET=0_"^error uploading file......" 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,"|")'="BGPELDCB"
.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 ^BGPELDCB(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPELDCB(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPELDCB(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPELDCB(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPELDCB(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPELDCB(" D IX1^DIK
ELPY ;
S DINUM=BGPIEN,X=$P(BGP1,U),DLAYGO=90547.04,DIC="^BGPELDPB(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 S BGPRET=0_"^error uploading file......" 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,"|")'="BGPELDPB"
.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 ^BGPELDPB(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPELDPB(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPELDPB(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPELDPB(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPELDPB(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPELDPB(" D IX1^DIK
ELBY ;
S DINUM=BGPIEN,X=$P(BGP1,U),DLAYGO=90547.05,DIC="^BGPELDBB(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 S BGPRET=0_"^error uploading file......" G EOJ
S BGPIEN=+Y
D ^XBFMK
N X
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,"|")'="BGPELDBB"
.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 ^BGPELDBB(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPELDBB(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPELDBB(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPELDBB(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPELDBB(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPELDBB(" D IX1^DIK
;W !,"Data uploaded."
D EOJ
Q
;
PROCPED ;
;W !,"Processing",!
S BGP1=$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(BGP1,U,X)
;find existing entry and if exists, delete it
N X
S (X,BGPOIEN)=0 F S X=$O(^BGPPEDCB(X)) Q:X'=+X S Y=^BGPPEDCB(X,0) D
.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="^BGPPEDCB(" D ^DIK S DA=BGPOIEN,DIK="^BGPPEDPB(" D ^DIK S DA=BGPOIEN,DIK="^BGPPEDBB(" D ^DIK
;add entry
L +^BGPPEDCB:10 I '$T S BGPRET=0_"^unable to lock global. TRY LATER" D EOJ Q
L +^BGPPEDPB:10 I '$T S BGPRET=0_"^unable to lock global. TRY LATER" D EOJ Q
L +^BGPPEDBB:10 I '$T S BGPRET=0_"^unable to lock global. TRY LATER" D EOJ Q
D GETIEN^BGP1PUTL
I 'BGPIEN S BGPRET=0_"^error in file creation...call programmer." D EOJ Q
PEDCY ;
S DINUM=BGPIEN,X=$P(BGP1,U),DLAYGO=90545.12,DIC="^BGPPEDCB(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 S BGPRET=0_"^error uploading file......" 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,"|")'="BGPPEDCB"
.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 ^BGPPEDCB(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPPEDCB(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPPEDCB(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPPEDCB(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPPEDCB(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPPEDCB(" D IX1^DIK
PEDPY ;
S DINUM=BGPIEN,X=$P(BGP1,U),DLAYGO=90545.13,DIC="^BGPPEDPB(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 S BGPRET=0_"^error uploading file......" 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,"|")'="BGPPEDPB"
.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 ^BGPPEDPB(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPPEDPB(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPPEDPB(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPPEDPB(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPPEDPB(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPPEDPB(" D IX1^DIK
PEDBY ;
S DINUM=BGPIEN,X=$P(BGP1,U),DLAYGO=90545.14,DIC="^BGPPEDBB(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 S BGPRET=0_"^error uploading file......" 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,"|")'="BGPPEDBB"
.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 ^BGPPEDBB(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPPEDBB(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPPEDBB(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPPEDBB(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPPEDBB(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPPEDBB(" D IX1^DIK
;W !,"Data uploaded."
D EOJ
Q
;
BGP1GUPL ; IHS/CMI/LAB - GUI Upload ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
+3 ;
EP(BGPRET,BGPUSER,BGPDUZ2,BGPOPTN,BGPDIR,BGPFILE,BGPRTIME) ;EP - called from GUI to produce COM REPORT CI05-AO-UPL
+1 ; SEE ROUTINE BGP1DL if you have questions about any of these variables
+2 ; BGPUSER - DUZ
+3 ; BGPDUZ2 - DUZ(2)
+4 ; BGPOPTN - OPTION NAME
+5 ; BGPFILE - FILE TO UPLOAD
+6 ;
+7 ;
+8 ; BGPRET - return value is ien^error message. a zero (0) is
+9 ; passed as ien if error occurred, display the filename back to the user
+10 ; if they chose to export to area
+11 ;
+12 ; I put the list of files in the BGPGUIB global in field 1100 as an output
+13 ;create entry in gui output file
+14 ;queue report to run with/GUIR
+15 DO EP1
+16 SET Y=$GET(BGPRET)
+17 ;D EN^XBVK("BGP") S:$D(ZTQUEUED) ZTREQ="@"
+18 IF '$PIECE($GET(BGPRET),U)
SET BGPRET=1_"^Upload OK"
+19 QUIT
EP1 ;
+1 SET U="^"
+2 IF $GET(BGPUSER)=""
SET BGPRET=0_"^USER NOT PASSED"
QUIT
+3 IF $GET(BGPDUZ2)=""
SET BGPRET=0_"^DUZ(2) NOT PASSED"
QUIT
+4 IF $GET(BGPOPTN)=""
SET BGPRET=0_"^OPTION NAME NOT PASSED"
QUIT
+5 IF $GET(BGPDIR)=""
SET BGPRET=0_"^DIRECTORY NAME NOT PASSED"
QUIT
+6 IF $GET(BGPFILE)=""
SET BGPRET=0_"^FILE NAME NOT PASSED"
QUIT
+7 SET BGPRTIME=$GET(BGPRTIME)
+8 ;S DUZ=BGPUSER
+9 SET DUZ(2)=BGPDUZ2
+10 IF '$DATA(DT)
SET DT=$$DT^XLFDT
+11 DO ^XBKVAR
+12 SET BGPGUI=1
+13 SET IOM=80
SET BGPIOSL=55
+14 ;SEND THE REPORT PROCESS OFF TO THE BACKGROUND USING TASKMAN CALL
AOUPL ;
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
SET BGPRET="0^CANNOT OPEN (OR ACCESS) FILE '"_BGPDIR_BGPFILE_"'."
DO EOJ
QUIT
+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 ;W !!,"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^BGP1GUP1
QUIT
+5 ;W !,"Processing",!
+6 SET BGP1=$PIECE($GET(^TMP("BGPUPL",$JOB,1,0)),"|",9)
+7 SET BGPG=$PIECE($GET(^TMP("BGPUPL",$JOB,1,0)),"|")
+8 FOR X=1:1:14
SET Y="BGP"_X
SET @Y=$PIECE(BGP1,U,X)
+9 ;find existing entry and if exists, delete it
+10 NEW X
+11 SET (X,BGPOIEN)=0
FOR
SET X=$ORDER(^BGPGPDCB(X))
IF X'=+X
QUIT
Begin DoDot:1
+12 IF '$DATA(^BGPGPDCB(X,0))
QUIT
+13 SET Y=^BGPGPDCB(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="^BGPGPDCB("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPGPDPB("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPGPDBB("
DO ^DIK
+29 ;add entry
+30 LOCK +^BGPGPDCB:10
IF '$TEST
SET BGPRET=0_"^unable to lock global. TRY LATER"
DO EOJ
QUIT
+31 LOCK +^BGPGPDPB:10
IF '$TEST
SET BGPRET=0_"^unable to lock global. TRY LATER"
DO EOJ
QUIT
+32 LOCK +^BGPGPDBB:10
IF '$TEST
SET BGPRET=0_"^unable to lock global. TRY LATER"
DO EOJ
QUIT
+33 DO GETIEN^BGP1UTL
+34 IF 'BGPIEN
SET BGPRET=0_"^error in file creation...call programmer."
DO EOJ
QUIT
CY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP1,U)
SET DLAYGO=90545.03
SET DIC="^BGPGPDCB("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
SET BGPRET=0_"^error uploading file......"
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,"|")'="BGPGPDCB"
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 ^BGPGPDCB(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPGPDCB(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPGPDCB(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPGPDCB(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPGPDCB(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPGPDCB("
DO IX1^DIK
PY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP1,U)
SET DLAYGO=90545.04
SET DIC="^BGPGPDPB("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
SET BGPRET=0_"^error uploading file......"
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,"|")'="BGPGPDPB"
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 ^BGPGPDPB(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPGPDPB(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPGPDPB(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPGPDPB(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPGPDPB(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPGPDPB("
DO IX1^DIK
BY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP1,U)
SET DLAYGO=90545.05
SET DIC="^BGPGPDBB("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
SET BGPRET=0_"^error uploading file......"
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,"|")'="BGPGPDBB"
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 ^BGPGPDBB(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPGPDBB(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPGPDBB(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPGPDBB(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPGPDBB(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPGPDBB("
DO IX1^DIK
+18 ;W !,"Data uploaded."
+19 DO EOJ
+20 QUIT
EOJ ;EP
+1 LOCK -^BGPGPDCB
+2 LOCK -^BGPGPDPB
+3 LOCK -^BGPGPDBB
+4 LOCK -^BGPHEDCB
+5 LOCK -^BGPHEDPB
+6 LOCK -^BGPHEDBB
+7 LOCK -^BGPELDCB
+8 LOCK -^BGPELDPB
+9 LOCK -^BGPELDBB
+10 LOCK -^BGPPEDCB
+11 LOCK -^BGPPEDPB
+12 LOCK -^BGPPEDBB
+13 LOCK -^BGPEOCB
+14 LOCK -^BGPEOBB
+15 LOCK -^BGPEOPB
+16 ;D EOP^BGP1DH
+17 KILL IOPAR
+18 ;D 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,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 ;W !,"Processing",!
+2 SET BGP1=$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(BGP1,U,X)
+5 ;find existing entry and if exists, delete it
+6 NEW X
+7 SET (X,BGPOIEN)=0
FOR
SET X=$ORDER(^BGPHEDCB(X))
IF X'=+X
QUIT
SET Y=^BGPHEDCB(X,0)
Begin DoDot:1
+8 IF $PIECE(Y,U)'=BGP1
QUIT
+9 IF $PIECE(Y,U,2)'=BGP2
QUIT
+10 IF $PIECE(Y,U,3)'=BGP3
QUIT
+11 IF $PIECE(Y,U,4)'=BGP4
QUIT
+12 IF $PIECE(Y,U,5)'=BGP5
QUIT
+13 IF $PIECE(Y,U,6)'=BGP6
QUIT
+14 IF $PIECE(Y,U,8)'=BGP8
QUIT
+15 IF $PIECE(Y,U,9)'=BGP9
QUIT
+16 IF $PIECE(Y,U,10)'=BGP10
QUIT
+17 IF $PIECE(Y,U,11)'=BGP11
QUIT
+18 IF $PIECE(Y,U,12)'=BGP12
QUIT
+19 IF $PIECE(Y,U,14)'=BGP14
QUIT
+20 SET BGPOIEN=X
End DoDot:1
+21 DO ^XBFMK
+22 IF BGPOIEN
SET DA=BGPOIEN
SET DIK="^BGPHEDCB("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPHEDPB("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPHEDBB("
DO ^DIK
+23 ;add entry
+24 LOCK +^BGPHEDCB:10
IF '$TEST
SET BGPRET=0_"^unable to lock global. TRY LATER"
DO EOJ
QUIT
+25 LOCK +^BGPHEDPB:10
IF '$TEST
SET BGPRET=0_"^unable to lock global. TRY LATER"
DO EOJ
QUIT
+26 LOCK +^BGPHEDBB:10
IF '$TEST
SET BGPRET=0_"^unable to lock global. TRY LATER"
DO EOJ
QUIT
+27 DO GETIEN^BGP1HUTL
+28 IF 'BGPIEN
SET BGPRET=0_"^error in file creation...call programmer."
DO EOJ
QUIT
HECY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP1,U)
SET DLAYGO=90546.03
SET DIC="^BGPHEDCB("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
SET BGPRET=0_"^error uploading file......"
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 NEW X
+8 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
+9 IF $PIECE(V,"|")'="BGPHEDCB"
QUIT
+10 SET V=$PIECE(V,"|",2,9999)
+11 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)
+12 IF N5]""
SET ^BGPHEDCB(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+13 IF N4]""
SET ^BGPHEDCB(BGPIEN,N,N2,N3,N4)=D
QUIT
+14 IF N3]""
SET ^BGPHEDCB(BGPIEN,N,N2,N3)=D
QUIT
+15 IF N2]""
SET ^BGPHEDCB(BGPIEN,N,N2)=D
QUIT
+16 IF N]""
SET ^BGPHEDCB(BGPIEN,N)=D
+17 QUIT
End DoDot:1
+18 SET DA=BGPIEN
SET DIK="^BGPHEDCB("
DO IX1^DIK
HEPY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP1,U)
SET DLAYGO=90546.04
SET DIC="^BGPHEDPB("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
SET BGPRET=0_"^error uploading file......"
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 NEW X
+8 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
+9 IF $PIECE(V,"|")'="BGPHEDPB"
QUIT
+10 SET V=$PIECE(V,"|",2,9999)
+11 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)
+12 IF N5]""
SET ^BGPHEDPB(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+13 IF N4]""
SET ^BGPHEDPB(BGPIEN,N,N2,N3,N4)=D
QUIT
+14 IF N3]""
SET ^BGPHEDPB(BGPIEN,N,N2,N3)=D
QUIT
+15 IF N2]""
SET ^BGPHEDPB(BGPIEN,N,N2)=D
QUIT
+16 IF N]""
SET ^BGPHEDPB(BGPIEN,N)=D
+17 QUIT
End DoDot:1
+18 SET DA=BGPIEN
SET DIK="^BGPHEDPB("
DO IX1^DIK
HEBY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP1,U)
SET DLAYGO=90546.05
SET DIC="^BGPHEDBB("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
SET BGPRET=0_"^error uploading file......"
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,"|")'="BGPHEDBB"
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 ^BGPHEDBB(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPHEDBB(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPHEDBB(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPHEDBB(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPHEDBB(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPHEDBB("
DO IX1^DIK
+18 ;W !,"Data uploaded."
+19 DO EOJ
+20 QUIT
+21 ;
PROCEL ;
+1 ;W !,"Processing",!
+2 SET BGP1=$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(BGP1,U,X)
+5 ;find existing entry and if exists, delete it
+6 NEW X
+7 SET (X,BGPOIEN)=0
FOR
SET X=$ORDER(^BGPELDCB(X))
IF X'=+X
QUIT
SET Y=^BGPELDCB(X,0)
Begin DoDot:1
+8 IF $PIECE(Y,U)'=BGP1
QUIT
+9 IF $PIECE(Y,U,2)'=BGP2
QUIT
+10 IF $PIECE(Y,U,3)'=BGP3
QUIT
+11 IF $PIECE(Y,U,4)'=BGP4
QUIT
+12 IF $PIECE(Y,U,5)'=BGP5
QUIT
+13 IF $PIECE(Y,U,6)'=BGP6
QUIT
+14 IF $PIECE(Y,U,8)'=BGP8
QUIT
+15 IF $PIECE(Y,U,9)'=BGP9
QUIT
+16 IF $PIECE(Y,U,10)'=BGP10
QUIT
+17 IF $PIECE(Y,U,11)'=BGP11
QUIT
+18 IF $PIECE(Y,U,12)'=BGP12
QUIT
+19 IF $PIECE(Y,U,14)'=BGP14
QUIT
+20 SET BGPOIEN=X
End DoDot:1
+21 DO ^XBFMK
+22 IF BGPOIEN
SET DA=BGPOIEN
SET DIK="^BGPELDCB("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPELDPB("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPELDBB("
DO ^DIK
+23 ;add entry
+24 LOCK +^BGPELDCB:10
IF '$TEST
SET BGPRET=0_"^unable to lock global. TRY LATER"
DO EOJ
QUIT
+25 LOCK +^BGPELDPB:10
IF '$TEST
SET BGPRET=0_"^unable to lock global. TRY LATER"
DO EOJ
QUIT
+26 LOCK +^BGPELDBB:10
IF '$TEST
SET BGPRET=0_"^unable to lock global. TRY LATER"
DO EOJ
QUIT
+27 DO GETIEN^BGP1EUTL
+28 IF 'BGPIEN
SET BGPRET=0_"^error in file creation...call programmer."
DO EOJ
QUIT
ELCY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP1,U)
SET DLAYGO=90547.03
SET DIC="^BGPELDCB("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
SET BGPRET=0_"^error uploading file......"
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,"|")'="BGPELDCB"
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 ^BGPELDCB(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPELDCB(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPELDCB(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPELDCB(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPELDCB(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPELDCB("
DO IX1^DIK
ELPY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP1,U)
SET DLAYGO=90547.04
SET DIC="^BGPELDPB("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
SET BGPRET=0_"^error uploading file......"
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,"|")'="BGPELDPB"
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 ^BGPELDPB(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPELDPB(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPELDPB(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPELDPB(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPELDPB(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPELDPB("
DO IX1^DIK
ELBY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP1,U)
SET DLAYGO=90547.05
SET DIC="^BGPELDBB("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
SET BGPRET=0_"^error uploading file......"
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 NEW X
+8 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
+9 IF $PIECE(V,"|")'="BGPELDBB"
QUIT
+10 SET V=$PIECE(V,"|",2,9999)
+11 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)
+12 IF N5]""
SET ^BGPELDBB(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+13 IF N4]""
SET ^BGPELDBB(BGPIEN,N,N2,N3,N4)=D
QUIT
+14 IF N3]""
SET ^BGPELDBB(BGPIEN,N,N2,N3)=D
QUIT
+15 IF N2]""
SET ^BGPELDBB(BGPIEN,N,N2)=D
QUIT
+16 IF N]""
SET ^BGPELDBB(BGPIEN,N)=D
+17 QUIT
End DoDot:1
+18 SET DA=BGPIEN
SET DIK="^BGPELDBB("
DO IX1^DIK
+19 ;W !,"Data uploaded."
+20 DO EOJ
+21 QUIT
+22 ;
PROCPED ;
+1 ;W !,"Processing",!
+2 SET BGP1=$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(BGP1,U,X)
+5 ;find existing entry and if exists, delete it
+6 NEW X
+7 SET (X,BGPOIEN)=0
FOR
SET X=$ORDER(^BGPPEDCB(X))
IF X'=+X
QUIT
SET Y=^BGPPEDCB(X,0)
Begin DoDot:1
+8 IF $PIECE(Y,U)'=BGP1
QUIT
+9 IF $PIECE(Y,U,2)'=BGP2
QUIT
+10 IF $PIECE(Y,U,3)'=BGP3
QUIT
+11 IF $PIECE(Y,U,4)'=BGP4
QUIT
+12 IF $PIECE(Y,U,5)'=BGP5
QUIT
+13 IF $PIECE(Y,U,6)'=BGP6
QUIT
+14 IF $PIECE(Y,U,7)'=BGP7
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 SET BGPOIEN=X
End DoDot:1
+21 DO ^XBFMK
+22 IF BGPOIEN
SET DA=BGPOIEN
SET DIK="^BGPPEDCB("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPPEDPB("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPPEDBB("
DO ^DIK
+23 ;add entry
+24 LOCK +^BGPPEDCB:10
IF '$TEST
SET BGPRET=0_"^unable to lock global. TRY LATER"
DO EOJ
QUIT
+25 LOCK +^BGPPEDPB:10
IF '$TEST
SET BGPRET=0_"^unable to lock global. TRY LATER"
DO EOJ
QUIT
+26 LOCK +^BGPPEDBB:10
IF '$TEST
SET BGPRET=0_"^unable to lock global. TRY LATER"
DO EOJ
QUIT
+27 DO GETIEN^BGP1PUTL
+28 IF 'BGPIEN
SET BGPRET=0_"^error in file creation...call programmer."
DO EOJ
QUIT
PEDCY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP1,U)
SET DLAYGO=90545.12
SET DIC="^BGPPEDCB("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
SET BGPRET=0_"^error uploading file......"
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,"|")'="BGPPEDCB"
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 ^BGPPEDCB(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPPEDCB(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPPEDCB(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPPEDCB(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPPEDCB(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPPEDCB("
DO IX1^DIK
PEDPY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP1,U)
SET DLAYGO=90545.13
SET DIC="^BGPPEDPB("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
SET BGPRET=0_"^error uploading file......"
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,"|")'="BGPPEDPB"
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 ^BGPPEDPB(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPPEDPB(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPPEDPB(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPPEDPB(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPPEDPB(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPPEDPB("
DO IX1^DIK
PEDBY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP1,U)
SET DLAYGO=90545.14
SET DIC="^BGPPEDBB("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
SET BGPRET=0_"^error uploading file......"
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,"|")'="BGPPEDBB"
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 ^BGPPEDBB(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPPEDBB(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPPEDBB(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPPEDBB(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPPEDBB(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPPEDBB("
DO IX1^DIK
+18 ;W !,"Data uploaded."
+19 DO EOJ
+20 QUIT
+21 ;
