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
FOR
SET BGPDT=$$FMADD^XLFDT(BGPDT,1)
IF $EXTRACT(BGPDT,4,5)'=$EXTRACT(DT,4,5)
QUIT
+20 SET X=BGPDT
DO DW^%DTC
IF X="FRIDAY"
SET BGPY=BGPY+1
+21 FOR
Begin DoDot:2
+22 SET (X,BGPDT)=$$FMADD^XLFDT(BGPDT,1)
+23 DO DW^%DTC
+24 IF X'="FRIDAY"
QUIT
+25 SET BGPY=BGPY+1
End DoDot:2
IF BGPY=2
QUIT
End DoDot:1
+26 SET BGPX=BGPDT_".12"
+27 ;D EDITOPT(BGPD0)
+28 ;ztload
+29 SET ZTDTH=BGPX
+30 ;S ZTSAVE("BGP*")=""
+31 SET ZTRTN="AUTO^BGP5AUUP"
+32 SET ZTDESC="BGP5 AUTO GPRA AREA AGGREGATE"
+33 SET ZTIO=""
+34 DO ^%ZTLOAD
+35 SET BGPTSK=$GET(ZTSK)
+36 QUIT
+37 ;
ADDOPT(BGPOPTD0,BGPD0) ;
+1 ;----- ADD OPTION TO OPTION SCHEDULING FILE
+2 ;
+3 NEW DD,DIC,DO,X,Y
+4 ;
+5 SET BGPD0=$ORDER(^DIC(19.2,"B",BGPOPTD0,0))
IF BGPD0
QUIT
+6 SET BGPD0=0
+7 SET X=BGPOPTD0
+8 SET DIC="^DIC(19.2,"
+9 SET DIC(0)=""
+10 DO FILE^DICN
+11 IF +Y'>0
QUIT
+12 SET BGPD0=+Y
+13 QUIT
EDITOPT(BGPD0) ;
+1 ;----- EDIT OPTION SCHEDULING OPTION
+2 ;
+3 NEW %DT,%L,%X,%Y,BGPDT,BGPF,DIFROM,D,D0,DA,DI,DIC,DIE,DIE,DQ,DR,X,Y
+4 ;
+5 SET BGPF="1M"
+6 SET DA=BGPD0
+7 SET DIE="^DIC(19.2,"
+8 SET DR="2///^S X=BGPX;6///^S X=BGPF"
+9 DO ^DIE
+10 QUIT
CHKFQT() ;EP - check for queued task (BGP AUTO GPRA EXTRACT and BGPSITE variable within the task
+1 NEW X,Y,Z,Q
+2 SET Y=$$FMTH^XLFDT(DT)
+3 ;not found
SET Q=""
+4 SET X=0
+5 FOR
SET X=$ORDER(^%ZTSK(X))
IF X'=+X
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^%ZTSK(X,0)),U,1,2)'="AUTO^BGP5AUUP"
QUIT
+7 ;"BGP 15 AUTO GPRA EXTRACT" ;not the gpra export
IF $PIECE($GET(^%ZTSK(X,.03)),U,1)'="BGP5 AUTO GPRA AREA AGGREGATE"
QUIT
+8 IF $PIECE($GET(^%ZTSK(X,0)),U,6)<Y
QUIT
+9 ;found it scheduled
SET Q=X
End DoDot:1
+10 QUIT Q
DEL ;EP
+1 KILL DIR
+2 SET DIR(0)="Y"
SET DIR("A")="Do you wish to Un-Schedule the task"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
WRITE !!,"Task still scheduled."
QUIT
+4 IF 'Y
WRITE !!,"Task still scheduled."
QUIT
+5 DO DELTASK^BGP5AUEX
+6 WRITE !!,"Task Un-Scheduled.",!
+7 QUIT
