- 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
