BGPDUP ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
;
;
W:$D(IOF) @IOF
W !,"This option is used to upload a SU's GPRA data.",!,"You must specify the directory in which the GPRA data file resides",!,"and then enter the filename of the GPRA data.",!
FILE ;upload global
DIR ;
K DIR
S BGPDIR=""
S DIR(0)="F^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 XIT
S BGPDIR=Y
S BGPFILE=""
S DIR(0)="F^2:30",DIR("A")="Enter filename w /ext (i.e. BG101201.5)" K DA D ^DIR K DIR
G:$D(DIRUT) DIR
S BGPFILE=Y
W !,"Directory=",BGPDIR," ","File=",BGPFILE
READF ;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 XIT
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 ;
W !,"Processing",!
S BGP0=$P($G(^TMP("BGPUPL",$J,1,0)),"|",8)
;I $L(BGP0,U)'=6 W "error in data" H 3 G XIT
F X=1:1:9 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(^BGPD(X)) Q:X'=+X S Y=^BGPD(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
.S BGPOIEN=X
D ^XBFMK
I BGPOIEN S DA=BGPOIEN,DIK="^BGPD(" D ^DIK
;add entry
S X=$P(BGP0,U),DLAYGO=90240.01,DIC="^BGPD(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 W !,"error uploading file......" H 4 G XIT
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
.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 ^BGPD(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPD(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPD(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPD(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPD(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPD(" D IX1^DIK
W !,"Data uploaded."
D XIT
Q
XIT ;
D EOP^BGPDH
K IOPAR
D HOME^%ZIS
D EN^XBVK("BGP")
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
;
;
BGPDUP ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
+1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
+2 ;
+3 ;
+4 IF $DATA(IOF)
WRITE @IOF
+5 WRITE !,"This option is used to upload a SU's GPRA data.",!,"You must specify the directory in which the GPRA data file resides",!,"and then enter the filename of the GPRA data.",!
FILE ;upload global
DIR ;
+1 KILL DIR
+2 SET BGPDIR=""
+3 SET DIR(0)="F^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 XIT
+5 SET BGPDIR=Y
+6 SET BGPFILE=""
+7 SET DIR(0)="F^2:30"
SET DIR("A")="Enter filename w /ext (i.e. BG101201.5)"
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
GOTO DIR
+9 SET BGPFILE=Y
+10 WRITE !,"Directory=",BGPDIR," ","File=",BGPFILE
READF ;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 XIT
+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 WRITE !,"Processing",!
+2 SET BGP0=$PIECE($GET(^TMP("BGPUPL",$JOB,1,0)),"|",8)
+3 ;I $L(BGP0,U)'=6 W "error in data" H 3 G XIT
+4 FOR X=1:1:9
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(^BGPD(X))
IF X'=+X
QUIT
SET Y=^BGPD(X,0)
Begin DoDot:1
+7 IF $PIECE(Y,U)'=BGP1
QUIT
+8 IF $PIECE(Y,U,2)'=BGP2
QUIT
+9 IF $PIECE(Y,U,3)'=BGP3
QUIT
+10 IF $PIECE(Y,U,4)'=BGP4
QUIT
+11 IF $PIECE(Y,U,5)'=BGP5
QUIT
+12 IF $PIECE(Y,U,6)'=BGP6
QUIT
+13 IF $PIECE(Y,U,8)'=BGP8
QUIT
+14 IF $PIECE(Y,U,9)'=+BGP9
QUIT
+15 SET BGPOIEN=X
End DoDot:1
+16 DO ^XBFMK
+17 IF BGPOIEN
SET DA=BGPOIEN
SET DIK="^BGPD("
DO ^DIK
+18 ;add entry
+19 SET X=$PIECE(BGP0,U)
SET DLAYGO=90240.01
SET DIC="^BGPD("
SET DIC(0)="L"
+20 KILL DD,D0,DO
+21 DO FILE^DICN
+22 IF Y=-1
WRITE !,"error uploading file......"
HANG 4
GOTO XIT
+23 SET BGPIEN=+Y
+24 DO ^XBFMK
+25 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
+26 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)
+27 IF N5]""
SET ^BGPD(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+28 IF N4]""
SET ^BGPD(BGPIEN,N,N2,N3,N4)=D
QUIT
+29 IF N3]""
SET ^BGPD(BGPIEN,N,N2,N3)=D
QUIT
+30 IF N2]""
SET ^BGPD(BGPIEN,N,N2)=D
QUIT
+31 IF N]""
SET ^BGPD(BGPIEN,N)=D
+32 QUIT
End DoDot:1
+33 SET DA=BGPIEN
SET DIK="^BGPD("
DO IX1^DIK
+34 WRITE !,"Data uploaded."
+35 DO XIT
+36 QUIT
XIT ;
+1 DO EOP^BGPDH
+2 KILL IOPAR
+3 DO HOME^%ZIS
+4 DO EN^XBVK("BGP")
+5 KILL X,X1,X2,X3,X4,X5,X6
+6 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
+7 KILL N,N1,N2,N3,N4,N5,N6
+8 KILL DIC,DA,X,Y,%Y,%,BGPJ,BGPX,BGPTEXT,BGPLINE,BGP
+9 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 ;
+5 ;
