BGP2AUUL ;IHS/CMI/LAB - AREA UPLOAD;
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
DESC ;----- ROUTINE DESCRIPTION
;;
;;This routine was copied from the BGP1ULF routine and modified to
;;remove user interaction and screen output and other unneeded stuff.
;;$$END
;
N I,X F I=1:1 S X=$P($T(DESC+I),";;",2) Q:X["$$END" D EN^DDIOL(X)
Q
;
EN(BGPDIR,BGPFILE) ;EP -- MAIN ENTRY POINT
; INPUT:
; BGPDIR = DIRECTORY
; BGPFILE = FILE TO BE PROCESSED
;
READF ;EP read file
NEW Y,X,I,BGPC
S BGPC=1
S Y=$$OPEN^%ZISH(BGPDIR,BGPFILE,"R")
I Y D G EOJ
. S BGPERR="UNABLE TO OPEN FILE '"_BGPDIR_BGPFILE_"'"
. ;S $ZR="<NOTOPEN>READF^BGPGPULF"
. ;D ^ZTER
KILL ^TMP("BGPGPUPL",$J)
F I=1:1 U IO R X:DTIME S X=$$STRIP(X) Q:X="" S ^TMP("BGPGPUPL",$J,BGPC,0)=X,BGPC=BGPC+1 Q:$$STATUS^%ZISH=-1
D ^%ZISC
PROC ;
S BGP0=$P($G(^TMP("BGPGPUPL",$J,1,0)),"|",9)
S BGPG=$P($G(^TMP("BGPGPUPL",$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(^BGPGPDCW(X)) Q:X'=+X D
.I '$D(^BGPGPDCW(X,0)) K ^BGPGPDCW(X) Q
.S Y=^BGPGPDCW(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="^BGPGPDCW(" D ^DIK S DA=BGPOIEN,DIK="^BGPGPDPW(" D ^DIK S DA=BGPOIEN,DIK="^BGPGPDBW(" D ^DIK
;add entry
L +^BGPGPDCW:10 I '$T D EOJ Q
L +^BGPGPDPW:10 I '$T D EOJ Q
L +^BGPGPDBW:10 I '$T D EOJ Q
D GETIEN^BGP2UTL
I 'BGPIEN D EOJ Q
CY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90548.03,DIC="^BGPGPDCW(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPGPDCW"
.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 ^BGPGPDCW(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPGPDCW(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPGPDCW(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPGPDCW(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPGPDCW(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPGPDCW(" D IX1^DIK
PY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90548.04,DIC="^BGPGPDPW(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPGPDPW"
.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 ^BGPGPDPW(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPGPDPW(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPGPDPW(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPGPDPW(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPGPDPW(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPGPDPW(" D IX1^DIK
BY ;
S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90548.05,DIC="^BGPGPDBW(",DIC(0)="L"
K DD,D0,DO
D FILE^DICN
I Y=-1 G EOJ
S BGPIEN=+Y
D ^XBFMK
S X=0 F S X=$O(^TMP("BGPGPUPL",$J,X)) Q:X'=+X S V=^TMP("BGPGPUPL",$J,X,0) D
.Q:$P(V,"|")'="BGPGPDBW"
.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 ^BGPGPDBW(BGPIEN,N,N2,N3,N4,N5)=D Q
.I N4]"" S ^BGPGPDBW(BGPIEN,N,N2,N3,N4)=D Q
.I N3]"" S ^BGPGPDBW(BGPIEN,N,N2,N3)=D Q
.I N2]"" S ^BGPGPDBW(BGPIEN,N,N2)=D Q
.I N]"" S ^BGPGPDBW(BGPIEN,N)=D
.Q
S DA=BGPIEN,DIK="^BGPGPDBW(" D IX1^DIK
D EOJ
Q
EOJ ;EP
L -^BGPGPDCW
L -^BGPGPDPW
L -^BGPGPDBW
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
BGP2AUUL ;IHS/CMI/LAB - AREA UPLOAD;
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+2 ;
DESC ;----- ROUTINE DESCRIPTION
+1 ;;
+2 ;;This routine was copied from the BGP1ULF routine and modified to
+3 ;;remove user interaction and screen output and other unneeded stuff.
+4 ;;$$END
+5 ;
+6 NEW I,X
FOR I=1:1
SET X=$PIECE($TEXT(DESC+I),";;",2)
IF X["$$END"
QUIT
DO EN^DDIOL(X)
+7 QUIT
+8 ;
EN(BGPDIR,BGPFILE) ;EP -- MAIN ENTRY POINT
+1 ; INPUT:
+2 ; BGPDIR = DIRECTORY
+3 ; BGPFILE = FILE TO BE PROCESSED
+4 ;
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
Begin DoDot:1
+5 SET BGPERR="UNABLE TO OPEN FILE '"_BGPDIR_BGPFILE_"'"
+6 ;S $ZR="<NOTOPEN>READF^BGPGPULF"
+7 ;D ^ZTER
End DoDot:1
GOTO EOJ
+8 KILL ^TMP("BGPGPUPL",$JOB)
+9 FOR I=1:1
USE IO
READ X:DTIME
SET X=$$STRIP(X)
IF X=""
QUIT
SET ^TMP("BGPGPUPL",$JOB,BGPC,0)=X
SET BGPC=BGPC+1
IF $$STATUS^%ZISH=-1
QUIT
+10 DO ^%ZISC
PROC ;
+1 SET BGP0=$PIECE($GET(^TMP("BGPGPUPL",$JOB,1,0)),"|",9)
+2 SET BGPG=$PIECE($GET(^TMP("BGPGPUPL",$JOB,1,0)),"|")
+3 FOR X=1:1:14
SET Y="BGP"_X
SET @Y=$PIECE(BGP0,U,X)
+4 ;find existing entry and if exists, delete it
+5 SET (X,BGPOIEN)=0
FOR
SET X=$ORDER(^BGPGPDCW(X))
IF X'=+X
QUIT
Begin DoDot:1
+6 IF '$DATA(^BGPGPDCW(X,0))
KILL ^BGPGPDCW(X)
QUIT
+7 SET Y=^BGPGPDCW(X,0)
+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="^BGPGPDCW("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPGPDPW("
DO ^DIK
SET DA=BGPOIEN
SET DIK="^BGPGPDBW("
DO ^DIK
+23 ;add entry
+24 LOCK +^BGPGPDCW:10
IF '$TEST
DO EOJ
QUIT
+25 LOCK +^BGPGPDPW:10
IF '$TEST
DO EOJ
QUIT
+26 LOCK +^BGPGPDBW:10
IF '$TEST
DO EOJ
QUIT
+27 DO GETIEN^BGP2UTL
+28 IF 'BGPIEN
DO EOJ
QUIT
CY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90548.03
SET DIC="^BGPGPDCW("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPGPDCW"
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 ^BGPGPDCW(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPGPDCW(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPGPDCW(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPGPDCW(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPGPDCW(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPGPDCW("
DO IX1^DIK
PY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90548.04
SET DIC="^BGPGPDPW("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPGPDPW"
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 ^BGPGPDPW(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPGPDPW(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPGPDPW(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPGPDPW(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPGPDPW(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPGPDPW("
DO IX1^DIK
BY ;
+1 SET DINUM=BGPIEN
SET X=$PIECE(BGP0,U)
SET DLAYGO=90548.05
SET DIC="^BGPGPDBW("
SET DIC(0)="L"
+2 KILL DD,D0,DO
+3 DO FILE^DICN
+4 IF Y=-1
GOTO EOJ
+5 SET BGPIEN=+Y
+6 DO ^XBFMK
+7 SET X=0
FOR
SET X=$ORDER(^TMP("BGPGPUPL",$JOB,X))
IF X'=+X
QUIT
SET V=^TMP("BGPGPUPL",$JOB,X,0)
Begin DoDot:1
+8 IF $PIECE(V,"|")'="BGPGPDBW"
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 ^BGPGPDBW(BGPIEN,N,N2,N3,N4,N5)=D
QUIT
+12 IF N4]""
SET ^BGPGPDBW(BGPIEN,N,N2,N3,N4)=D
QUIT
+13 IF N3]""
SET ^BGPGPDBW(BGPIEN,N,N2,N3)=D
QUIT
+14 IF N2]""
SET ^BGPGPDBW(BGPIEN,N,N2)=D
QUIT
+15 IF N]""
SET ^BGPGPDBW(BGPIEN,N)=D
+16 QUIT
End DoDot:1
+17 SET DA=BGPIEN
SET DIK="^BGPGPDBW("
DO IX1^DIK
+18 DO EOJ
+19 QUIT
EOJ ;EP
+1 LOCK -^BGPGPDCW
+2 LOCK -^BGPGPDPW
+3 LOCK -^BGPGPDBW
+4 KILL IOPAR
+5 DO HOME^%ZIS
+6 KILL X,X1,X2,X3,X4,X5,X6
+7 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
+8 KILL N,N1,N2,N3,N4,N5,N6
+9 KILL DIC,DA,X,Y,%Y,%,BGPJ,BGPX,BGPTEXT,BGPLINE,BGP
+10 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
