BGP5AUUL.m

BGP5AUUL ;IHS/CMI/LAB - AREA UPLOAD;

 ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143

 ;

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,21 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(^BGPGPDCK(X)) Q:X'=+X  D

 .I '$D(^BGPGPDCK(X,0)) K ^BGPGPDCK(X) Q

 .S Y=^BGPGPDCK(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

 .Q:$P(Y,U,21)'=BGP21

 .S BGPOIEN=X

 D ^XBFMK

 I BGPOIEN S DA=BGPOIEN,DIK="^BGPGPDCK(" D ^DIK S DA=BGPOIEN,DIK="^BGPGPDPK(" D ^DIK S DA=BGPOIEN,DIK="^BGPGPDBK(" D ^DIK

 ;add entry

 L +^BGPGPDCK:10 I '$T D EOJ Q

 L +^BGPGPDPK:10 I '$T D EOJ Q

 L +^BGPGPDBK:10 I '$T D EOJ Q

 D GETIEN^BGP5UTL

 I 'BGPIEN D EOJ Q

CY ;

 S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90554.03,DIC="^BGPGPDCK(",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,"|")'="BGPGPDCK"

 .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 ^BGPGPDCK(BGPIEN,N,N2,N3,N4,N5)=D Q

 .I N4]"" S ^BGPGPDCK(BGPIEN,N,N2,N3,N4)=D Q

 .I N3]"" S ^BGPGPDCK(BGPIEN,N,N2,N3)=D Q

 .I N2]"" S ^BGPGPDCK(BGPIEN,N,N2)=D Q

 .I N]"" S ^BGPGPDCK(BGPIEN,N)=D

 .Q

 S DA=BGPIEN,DIK="^BGPGPDCK(" D IX1^DIK

PY ;

 S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90554.04,DIC="^BGPGPDPK(",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,"|")'="BGPGPDPK"

 .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 ^BGPGPDPK(BGPIEN,N,N2,N3,N4,N5)=D Q

 .I N4]"" S ^BGPGPDPK(BGPIEN,N,N2,N3,N4)=D Q

 .I N3]"" S ^BGPGPDPK(BGPIEN,N,N2,N3)=D Q

 .I N2]"" S ^BGPGPDPK(BGPIEN,N,N2)=D Q

 .I N]"" S ^BGPGPDPK(BGPIEN,N)=D

 .Q

 S DA=BGPIEN,DIK="^BGPGPDPK(" D IX1^DIK

BY ;

 S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90554.05,DIC="^BGPGPDBK(",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,"|")'="BGPGPDBK"

 .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 ^BGPGPDBK(BGPIEN,N,N2,N3,N4,N5)=D Q

 .I N4]"" S ^BGPGPDBK(BGPIEN,N,N2,N3,N4)=D Q

 .I N3]"" S ^BGPGPDBK(BGPIEN,N,N2,N3)=D Q

 .I N2]"" S ^BGPGPDBK(BGPIEN,N,N2)=D Q

 .I N]"" S ^BGPGPDBK(BGPIEN,N)=D

 .Q

 S DA=BGPIEN,DIK="^BGPGPDBK(" D IX1^DIK

 D EOJ

 Q

EOJ ;EP

 L -^BGPGPDCK

 L -^BGPGPDPK

 L -^BGPGPDBK

 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

 K BGP1,BGP2,BGP3,BGP4,BGP5,BGP6,BGP7,BGP8,BGP9,BGP10,BGP11,BGP12,BGP13,BGP14,BGP21

 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

SCH ;EP - called from option to schedule the area aggregate for the next "2nd Friday"

 ;INFORM

 W !!,"This option is used to automatically schedule the Auto Area"

 W !,"file aggregation for the second Friday of the month.",!

 S BGPTASK=$$CHKFQT()

 I BGPTASK W !!,"The option is already scheduled to run: TASK # ",BGPTASK," at ",$$HTE^XLFDT($P(^%ZTSK(BGPTASK,0),U,6)),"." D DEL,PAUSE^BGP5DU,XIT^BGP5AUUP Q

 NEW BGPDT,BGPX,BGPY

 S BGPDT=DT

 ;get next "second Friday" in this month

 ;S BGPX=$E(DT,1,5)_"01"  ;first of this month

 S BGPY=0  ;friday counter

 ;S X=DT

 ;D DW^%DTC

 D

 . S BGPDT=$E(DT,1,5)_"01"

 . S X=BGPDT D DW^%DTC I X="FRIDAY" S BGPY=BGPY+1

 . F  D  Q:BGPY=2

 . . S (X,BGPDT)=$$FMADD^XLFDT(BGPDT,1)

 . . D DW^%DTC

 . . Q:X'="FRIDAY"

 . . S BGPY=BGPY+1

 I BGPDT<DT D

 .;ADD 1 TO bgpdt Until the month changs

 .S BGPY=0

 .S BGPDT=DT F  S BGPDT=$$FMADD^XLFDT(BGPDT,1) Q:$E(BGPDT,4,5)'=$E(DT,4,5)

 .S X=BGPDT D DW^%DTC I X="FRIDAY" S BGPY=BGPY+1

 .F  D  Q:BGPY=2

 ..S (X,BGPDT)=$$FMADD^XLFDT(BGPDT,1)

 ..D DW^%DTC

 ..Q:X'="FRIDAY"

 ..S BGPY=BGPY+1

 W !,"This option will be scheduled for ",$$FMTE^XLFDT(BGPDT)," at 12:00pm.",!

 K DIR

 S DIR(0)="Y",DIR("A")="Do you wish to continue and schedule it",DIR("B")="Y" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) Q

 I 'Y Q

 ;S BGPOPT="BGP 15 AUTO PROC SITE FILES"

 ;S BGPOPTD0=$O(^DIC(19,"B",BGPOPT,0))

 ;I 'BGPOPTD0 D  Q

 ;. D BMES^XPDUTL("'BGP 15 AUTO PROC SITE FILES' OPTION NOT FOUND!")

 ;. D PAUSE^BGP5DU

 ;. D XIT^BGP5AUUP

 ;Q:'BGPOPTD0

 ;S BGPD0=$O(^DIC(19.2,"B",BGPOPTD0,0))

 ;D ADDOPT(BGPOPTD0,.BGPD0)

 S BGPX=BGPDT_".12"

 ;D EDITOPT(BGPD0)

 ;ztload

 S ZTDTH=BGPX

 ;S ZTSAVE("BGP*")=""

 S ZTRTN="AUTO^BGP5AUUP"

 S ZTDESC="BGP5 AUTO GPRA AREA AGGREGATE"

 S ZTIO=""

 D ^%ZTLOAD

 S BGPTSK=$G(ZTSK)

 D BMES^XPDUTL("OPTION 'BGP5 AUTO AREA AGGREGATE' SCHEDULED AS TASK #"_BGPTSK)

 D PAUSE^BGP5DU,XIT^BGP5AUUP

 Q

SCHGUI ;EP -- gui scheduler

 NEW BGPDT,BGPX,BGPY

 S BGPDT=DT

 ;get next "second Friday" in this month

 ;S BGPX=$E(DT,1,5)_"01"  ;first of this month

 S BGPY=0  ;friday counter

 ;S X=DT

 ;D DW^%DTC

 D

 . S BGPDT=$E(DT,1,5)_"01"

 . S X=BGPDT D DW^%DTC I X="FRIDAY" S BGPY=BGPY+1

 . F  D  Q:BGPY=2

 . . S (X,BGPDT)=$$FMADD^XLFDT(BGPDT,1)

 . . D DW^%DTC

 . . Q:X'="FRIDAY"

 . . S BGPY=BGPY+1

 I BGPDT<DT D

 .;ADD 1 TO bgpdt Until the month changs

 .S BGPY=0

 .S BGPDT=DT F  S BGPDT=$$FMADD^XLFDT(BGPDT,1) Q:$E(BGPDT,4,5)'=$E(DT,4,5)

 .S X=BGPDT D DW^%DTC I X="FRIDAY" S BGPY=BGPY+1

 .F  D  Q:BGPY=2

 ..S (X,BGPDT)=$$FMADD^XLFDT(BGPDT,1)

 ..D DW^%DTC

 ..Q:X'="FRIDAY"

 ..S BGPY=BGPY+1

 S BGPX=BGPDT_".12"

 ;D EDITOPT(BGPD0)

 ;ztload

 S ZTDTH=BGPX

 ;S ZTSAVE("BGP*")=""

 S ZTRTN="AUTO^BGP5AUUP"

 S ZTDESC="BGP5 AUTO GPRA AREA AGGREGATE"

 S ZTIO=""

 D ^%ZTLOAD

 S BGPTSK=$G(ZTSK)

 Q

 ;

ADDOPT(BGPOPTD0,BGPD0) ;

 ;----- ADD OPTION TO OPTION SCHEDULING FILE

 ;

 N DD,DIC,DO,X,Y

 ;

 S BGPD0=$O(^DIC(19.2,"B",BGPOPTD0,0)) I BGPD0 Q

 S BGPD0=0

 S X=BGPOPTD0

 S DIC="^DIC(19.2,"

 S DIC(0)=""

 D FILE^DICN

 Q:+Y'>0

 S BGPD0=+Y

 Q

EDITOPT(BGPD0) ;

 ;----- EDIT OPTION SCHEDULING OPTION

 ;

 N %DT,%L,%X,%Y,BGPDT,BGPF,DIFROM,D,D0,DA,DI,DIC,DIE,DIE,DQ,DR,X,Y

 ;

 S BGPF="1M"

 S DA=BGPD0

 S DIE="^DIC(19.2,"

 S DR="2///^S X=BGPX;6///^S X=BGPF"

 D ^DIE

 Q

CHKFQT() ;EP - check for queued task (BGP AUTO GPRA EXTRACT and BGPSITE variable within the task

 NEW X,Y,Z,Q

 S Y=$$FMTH^XLFDT(DT)

 S Q=""  ;not found

 S X=0

 F  S X=$O(^%ZTSK(X)) Q:X'=+X  D

 .Q:$P($G(^%ZTSK(X,0)),U,1,2)'="AUTO^BGP5AUUP"

 .Q:$P($G(^%ZTSK(X,.03)),U,1)'="BGP5 AUTO GPRA AREA AGGREGATE"  ;"BGP 15 AUTO GPRA EXTRACT"  ;not the gpra export

 .Q:$P($G(^%ZTSK(X,0)),U,6)<Y

 .S Q=X  ;found it scheduled

 Q Q

DEL ;EP

 K DIR

 S DIR(0)="Y",DIR("A")="Do you wish to Un-Schedule the task",DIR("B")="N" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) W !!,"Task still scheduled." Q

 I 'Y W !!,"Task still scheduled." Q

 D DELTASK^BGP5AUEX

 W !!,"Task Un-Scheduled.",!

 Q

BGP5AUUL  ;IHS/CMI/LAB - AREA UPLOAD;

 +1       ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143

 +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,21

               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(^BGPGPDCK(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +6                IF '$DATA(^BGPGPDCK(X,0))

                       KILL ^BGPGPDCK(X)

                       QUIT 

 +7                SET Y=^BGPGPDCK(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               IF $PIECE(Y,U,21)'=BGP21

                       QUIT 

 +21               SET BGPOIEN=X

               End DoDot:1

 +22       DO ^XBFMK

 +23       IF BGPOIEN

               SET DA=BGPOIEN

               SET DIK="^BGPGPDCK("

               DO ^DIK

               SET DA=BGPOIEN

               SET DIK="^BGPGPDPK("

               DO ^DIK

               SET DA=BGPOIEN

               SET DIK="^BGPGPDBK("

               DO ^DIK

 +24      ;add entry

 +25       LOCK +^BGPGPDCK:10

           IF '$TEST

               DO EOJ

               QUIT 

 +26       LOCK +^BGPGPDPK:10

           IF '$TEST

               DO EOJ

               QUIT 

 +27       LOCK +^BGPGPDBK:10

           IF '$TEST

               DO EOJ

               QUIT 

 +28       DO GETIEN^BGP5UTL

 +29       IF 'BGPIEN

               DO EOJ

               QUIT 

CY        ;

 +1        SET DINUM=BGPIEN

           SET X=$PIECE(BGP0,U)

           SET DLAYGO=90554.03

           SET DIC="^BGPGPDCK("

           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,"|")'="BGPGPDCK"

                       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 ^BGPGPDCK(BGPIEN,N,N2,N3,N4,N5)=D

                       QUIT 

 +12               IF N4]""

                       SET ^BGPGPDCK(BGPIEN,N,N2,N3,N4)=D

                       QUIT 

 +13               IF N3]""

                       SET ^BGPGPDCK(BGPIEN,N,N2,N3)=D

                       QUIT 

 +14               IF N2]""

                       SET ^BGPGPDCK(BGPIEN,N,N2)=D

                       QUIT 

 +15               IF N]""

                       SET ^BGPGPDCK(BGPIEN,N)=D

 +16               QUIT 

               End DoDot:1

 +17       SET DA=BGPIEN

           SET DIK="^BGPGPDCK("

           DO IX1^DIK

PY        ;

 +1        SET DINUM=BGPIEN

           SET X=$PIECE(BGP0,U)

           SET DLAYGO=90554.04

           SET DIC="^BGPGPDPK("

           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,"|")'="BGPGPDPK"

                       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 ^BGPGPDPK(BGPIEN,N,N2,N3,N4,N5)=D

                       QUIT 

 +12               IF N4]""

                       SET ^BGPGPDPK(BGPIEN,N,N2,N3,N4)=D

                       QUIT 

 +13               IF N3]""

                       SET ^BGPGPDPK(BGPIEN,N,N2,N3)=D

                       QUIT 

 +14               IF N2]""

                       SET ^BGPGPDPK(BGPIEN,N,N2)=D

                       QUIT 

 +15               IF N]""

                       SET ^BGPGPDPK(BGPIEN,N)=D

 +16               QUIT 

               End DoDot:1

 +17       SET DA=BGPIEN

           SET DIK="^BGPGPDPK("

           DO IX1^DIK

BY        ;

 +1        SET DINUM=BGPIEN

           SET X=$PIECE(BGP0,U)

           SET DLAYGO=90554.05

           SET DIC="^BGPGPDBK("

           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,"|")'="BGPGPDBK"

                       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 ^BGPGPDBK(BGPIEN,N,N2,N3,N4,N5)=D

                       QUIT 

 +12               IF N4]""

                       SET ^BGPGPDBK(BGPIEN,N,N2,N3,N4)=D

                       QUIT 

 +13               IF N3]""

                       SET ^BGPGPDBK(BGPIEN,N,N2,N3)=D

                       QUIT 

 +14               IF N2]""

                       SET ^BGPGPDBK(BGPIEN,N,N2)=D

                       QUIT 

 +15               IF N]""

                       SET ^BGPGPDBK(BGPIEN,N)=D

 +16               QUIT 

               End DoDot:1

 +17       SET DA=BGPIEN

           SET DIK="^BGPGPDBK("

           DO IX1^DIK

 +18       DO EOJ

 +19       QUIT 

EOJ       ;EP

 +1        LOCK -^BGPGPDCK

 +2        LOCK -^BGPGPDPK

 +3        LOCK -^BGPGPDBK

 +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       KILL BGP1,BGP2,BGP3,BGP4,BGP5,BGP6,BGP7,BGP8,BGP9,BGP10,BGP11,BGP12,BGP13,BGP14,BGP21

 +11       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

SCH       ;EP - called from option to schedule the area aggregate for the next "2nd Friday"

 +1       ;INFORM

 +2        WRITE !!,"This option is used to automatically schedule the Auto Area"

 +3        WRITE !,"file aggregation for the second Friday of the month.",!

 +4        SET BGPTASK=$$CHKFQT()

 +5        IF BGPTASK

               WRITE !!,"The option is already scheduled to run: TASK # ",BGPTASK," at ",$$HTE^XLFDT($PIECE(^%ZTSK(BGPTASK,0),U,6)),"."

               DO DEL

               DO PAUSE^BGP5DU

               DO XIT^BGP5AUUP

               QUIT 

 +6        NEW BGPDT,BGPX,BGPY

 +7        SET BGPDT=DT

 +8       ;get next "second Friday" in this month

 +9       ;S BGPX=$E(DT,1,5)_"01"  ;first of this month

 +10      ;friday counter

           SET BGPY=0

 +11      ;S X=DT

 +12      ;D DW^%DTC

 +13       Begin DoDot:1

 +14           SET BGPDT=$EXTRACT(DT,1,5)_"01"

 +15           SET X=BGPDT

               DO DW^%DTC

               IF X="FRIDAY"

                   SET BGPY=BGPY+1

 +16           FOR 

                   Begin DoDot:2

 +17                   SET (X,BGPDT)=$$FMADD^XLFDT(BGPDT,1)

 +18                   DO DW^%DTC

 +19                   IF X'="FRIDAY"

                           QUIT 

 +20                   SET BGPY=BGPY+1

                   End DoDot:2

                   IF BGPY=2

                       QUIT 

           End DoDot:1

 +21       IF BGPDT<DT

               Begin DoDot:1

 +22      ;ADD 1 TO bgpdt Until the month changs

 +23               SET BGPY=0

 +24               SET BGPDT=DT

                   FOR 

                       SET BGPDT=$$FMADD^XLFDT(BGPDT,1)

                       IF $EXTRACT(BGPDT,4,5)'=$EXTRACT(DT,4,5)

                           QUIT 

 +25               SET X=BGPDT

                   DO DW^%DTC

                   IF X="FRIDAY"

                       SET BGPY=BGPY+1

 +26               FOR 

                       Begin DoDot:2

 +27                       SET (X,BGPDT)=$$FMADD^XLFDT(BGPDT,1)

 +28                       DO DW^%DTC

 +29                       IF X'="FRIDAY"

                               QUIT 

 +30                       SET BGPY=BGPY+1

                       End DoDot:2

                       IF BGPY=2

                           QUIT 

               End DoDot:1

 +31       WRITE !,"This option will be scheduled for ",$$FMTE^XLFDT(BGPDT)," at 12:00pm.",!

 +32       KILL DIR

 +33       SET DIR(0)="Y"

           SET DIR("A")="Do you wish to continue and schedule it"

           SET DIR("B")="Y"

           KILL DA

           DO ^DIR

           KILL DIR

 +34       IF $DATA(DIRUT)

               QUIT 

 +35       IF 'Y

               QUIT 

 +36      ;S BGPOPT="BGP 15 AUTO PROC SITE FILES"

 +37      ;S BGPOPTD0=$O(^DIC(19,"B",BGPOPT,0))

 +38      ;I 'BGPOPTD0 D  Q

 +39      ;. D BMES^XPDUTL("'BGP 15 AUTO PROC SITE FILES' OPTION NOT FOUND!")

 +40      ;. D PAUSE^BGP5DU

 +41      ;. D XIT^BGP5AUUP

 +42      ;Q:'BGPOPTD0

 +43      ;S BGPD0=$O(^DIC(19.2,"B",BGPOPTD0,0))

 +44      ;D ADDOPT(BGPOPTD0,.BGPD0)

 +45       SET BGPX=BGPDT_".12"

 +46      ;D EDITOPT(BGPD0)

 +47      ;ztload

 +48       SET ZTDTH=BGPX

 +49      ;S ZTSAVE("BGP*")=""

 +50       SET ZTRTN="AUTO^BGP5AUUP"

 +51       SET ZTDESC="BGP5 AUTO GPRA AREA AGGREGATE"

 +52       SET ZTIO=""

 +53       DO ^%ZTLOAD

 +54       SET BGPTSK=$GET(ZTSK)

 +55       DO BMES^XPDUTL("OPTION 'BGP5 AUTO AREA AGGREGATE' SCHEDULED AS TASK #"_BGPTSK)

 +56       DO PAUSE^BGP5DU

           DO XIT^BGP5AUUP

 +57       QUIT 

SCHGUI    ;EP -- gui scheduler

 +1        NEW BGPDT,BGPX,BGPY

 +2        SET BGPDT=DT

 +3       ;get next "second Friday" in this month

 +4       ;S BGPX=$E(DT,1,5)_"01"  ;first of this month

 +5       ;friday counter

           SET BGPY=0

 +6       ;S X=DT

 +7       ;D DW^%DTC

 +8        Begin DoDot:1

 +9            SET BGPDT=$EXTRACT(DT,1,5)_"01"

 +10           SET X=BGPDT

               DO DW^%DTC

               IF X="FRIDAY"

                   SET BGPY=BGPY+1

 +11           FOR 

                   Begin DoDot:2

 +12                   SET (X,BGPDT)=$$FMADD^XLFDT(BGPDT,1)

 +13                   DO DW^%DTC

 +14                   IF X'="FRIDAY"

                           QUIT 

 +15                   SET BGPY=BGPY+1

                   End DoDot:2

                   IF BGPY=2

                       QUIT 

           End DoDot:1

 +16       IF BGPDT<DT

               Begin DoDot:1

 +17      ;ADD 1 TO bgpdt Until the month changs

 +18               SET BGPY=0

 +19               SET BGPDT=DT