Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP3AUUL

BGP3AUUL.m

Go to the documentation of this file. 
  1. BGP3AUUL ;IHS/CMI/LAB - AREA UPLOAD;
  1.  ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
  1.  ;
  1. DESC ;----- ROUTINE DESCRIPTION
  1.  ;; 
  1.  ;;This routine was copied from the BGP1ULF routine and modified to
  1.  ;;remove user interaction and screen output and other unneeded stuff.
  1.  ;;$$END
  1.  ;
  1.  N I,X F I=1:1 S X=$P($T(DESC+I),";;",2) Q:X["$$END"  D EN^DDIOL(X)
  1.  Q
  1.  ;
  1. EN(BGPDIR,BGPFILE) ;EP -- MAIN ENTRY POINT
  1.  ;      INPUT:
  1.  ;      BGPDIR   =  DIRECTORY
  1.  ;      BGPFILE  =  FILE TO BE PROCESSED
  1.  ;
  1. READF ;EP read file
  1.  NEW Y,X,I,BGPC
  1.  S BGPC=1
  1.  S Y=$$OPEN^%ZISH(BGPDIR,BGPFILE,"R")
  1.  I Y D  G EOJ
  1.  . S BGPERR="UNABLE TO OPEN FILE '"_BGPDIR_BGPFILE_"'"
  1.  . ;S $ZR="<NOTOPEN>READF^BGPGPULF"
  1.  . ;D ^ZTER 
  1.  KILL ^TMP("BGPGPUPL",$J)
  1.  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
  1.  D ^%ZISC
  1. PROC ;
  1.  S BGP0=$P($G(^TMP("BGPGPUPL",$J,1,0)),"|",9)
  1.  S BGPG=$P($G(^TMP("BGPGPUPL",$J,1,0)),"|")
  1.  F X=1:1:14 S Y="BGP"_X,@Y=$P(BGP0,U,X)
  1.  ;find existing entry and if exists, delete it
  1.  S (X,BGPOIEN)=0 F  S X=$O(^BGPGPDCH(X)) Q:X'=+X  D
  1.  .I '$D(^BGPGPDCH(X,0)) K ^BGPGPDCH(X) Q
  1.  .S Y=^BGPGPDCH(X,0)
  1.  .Q:$P(Y,U)'=BGP1
  1.  .Q:$P(Y,U,2)'=BGP2
  1.  .Q:$P(Y,U,3)'=BGP3
  1.  .Q:$P(Y,U,4)'=BGP4
  1.  .Q:$P(Y,U,5)'=BGP5
  1.  .Q:$P(Y,U,6)'=BGP6
  1.  .Q:$P(Y,U,8)'=BGP8
  1.  .Q:$P(Y,U,9)'=BGP9
  1.  .Q:$P(Y,U,10)'=BGP10
  1.  .Q:$P(Y,U,11)'=BGP11
  1.  .Q:$P(Y,U,12)'=BGP12
  1.  .Q:$P(Y,U,14)'=BGP14
  1.  .S BGPOIEN=X
  1.  D ^XBFMK
  1.  I BGPOIEN S DA=BGPOIEN,DIK="^BGPGPDCH(" D ^DIK S DA=BGPOIEN,DIK="^BGPGPDPH(" D ^DIK S DA=BGPOIEN,DIK="^BGPGPDBH(" D ^DIK
  1.  ;add entry
  1.  L +^BGPGPDCH:10 I '$T D EOJ Q
  1.  L +^BGPGPDPH:10 I '$T D EOJ Q
  1.  L +^BGPGPDBH:10 I '$T D EOJ Q
  1.  D GETIEN^BGP3UTL
  1.  I 'BGPIEN D EOJ Q
  1. CY ;
  1.  S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90550.03,DIC="^BGPGPDCH(",DIC(0)="L"
  1.  K DD,D0,DO
  1.  D FILE^DICN
  1.  I Y=-1 G EOJ
  1.  S BGPIEN=+Y
  1.  D ^XBFMK
  1.  S X=0 F  S X=$O(^TMP("BGPGPUPL",$J,X)) Q:X'=+X  S V=^TMP("BGPGPUPL",$J,X,0) D
  1.  .Q:$P(V,"|")'="BGPGPDCH"
  1.  .S V=$P(V,"|",2,9999)
  1.  .S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
  1.  .I N5]"" S ^BGPGPDCH(BGPIEN,N,N2,N3,N4,N5)=D Q
  1.  .I N4]"" S ^BGPGPDCH(BGPIEN,N,N2,N3,N4)=D Q
  1.  .I N3]"" S ^BGPGPDCH(BGPIEN,N,N2,N3)=D Q
  1.  .I N2]"" S ^BGPGPDCH(BGPIEN,N,N2)=D Q
  1.  .I N]"" S ^BGPGPDCH(BGPIEN,N)=D
  1.  .Q
  1.  S DA=BGPIEN,DIK="^BGPGPDCH(" D IX1^DIK
  1. PY ;
  1.  S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90550.04,DIC="^BGPGPDPH(",DIC(0)="L"
  1.  K DD,D0,DO
  1.  D FILE^DICN
  1.  I Y=-1 G EOJ
  1.  S BGPIEN=+Y
  1.  D ^XBFMK
  1.  S X=0 F  S X=$O(^TMP("BGPGPUPL",$J,X)) Q:X'=+X  S V=^TMP("BGPGPUPL",$J,X,0) D
  1.  .Q:$P(V,"|")'="BGPGPDPH"
  1.  .S V=$P(V,"|",2,9999)
  1.  .S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
  1.  .I N5]"" S ^BGPGPDPH(BGPIEN,N,N2,N3,N4,N5)=D Q
  1.  .I N4]"" S ^BGPGPDPH(BGPIEN,N,N2,N3,N4)=D Q
  1.  .I N3]"" S ^BGPGPDPH(BGPIEN,N,N2,N3)=D Q
  1.  .I N2]"" S ^BGPGPDPH(BGPIEN,N,N2)=D Q
  1.  .I N]"" S ^BGPGPDPH(BGPIEN,N)=D
  1.  .Q
  1.  S DA=BGPIEN,DIK="^BGPGPDPH(" D IX1^DIK
  1. BY ;
  1.  S DINUM=BGPIEN,X=$P(BGP0,U),DLAYGO=90550.05,DIC="^BGPGPDBH(",DIC(0)="L"
  1.  K DD,D0,DO
  1.  D FILE^DICN
  1.  I Y=-1 G EOJ
  1.  S BGPIEN=+Y
  1.  D ^XBFMK
  1.  S X=0 F  S X=$O(^TMP("BGPGPUPL",$J,X)) Q:X'=+X  S V=^TMP("BGPGPUPL",$J,X,0) D
  1.  .Q:$P(V,"|")'="BGPGPDBH"
  1.  .S V=$P(V,"|",2,9999)
  1.  .S N=$P(V,"|"),N2=$P(V,"|",2),N3=$P(V,"|",3),N4=$P(V,"|",4),N5=$P(V,"|",5),D=$P(V,"|",8)
  1.  .I N5]"" S ^BGPGPDBH(BGPIEN,N,N2,N3,N4,N5)=D Q
  1.  .I N4]"" S ^BGPGPDBH(BGPIEN,N,N2,N3,N4)=D Q
  1.  .I N3]"" S ^BGPGPDBH(BGPIEN,N,N2,N3)=D Q
  1.  .I N2]"" S ^BGPGPDBH(BGPIEN,N,N2)=D Q
  1.  .I N]"" S ^BGPGPDBH(BGPIEN,N)=D
  1.  .Q
  1.  S DA=BGPIEN,DIK="^BGPGPDBH(" D IX1^DIK
  1.  D EOJ
  1.  Q
  1. EOJ ;EP
  1.  L -^BGPGPDCH
  1.  L -^BGPGPDPH
  1.  L -^BGPGPDBH
  1.  K IOPAR
  1.  D HOME^%ZIS
  1.  K X,X1,X2,X3,X4,X5,X6
  1.  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
  1.  K N,N1,N2,N3,N4,N5,N6
  1.  K DIC,DA,X,Y,%Y,%,BGPJ,BGPX,BGPTEXT,BGPLINE,BGP
  1.  Q
  1. STRIP(Z) ;REMOVE CONTROLL CHARACTERS
  1.  NEW I
  1.  F I=1:1:$L(Z) I (32>$A($E(Z,I))) S Z=$E(Z,1,I-1)_""_$E(Z,I+1,999)
  1.  Q Z
  1. SCH ;EP - called from option to schedule the area aggregate for the next "2nd Friday"
  1.  ;INFORM
  1.  W !!,"This option is used to automatically schedule the Auto Area"
  1.  W !,"file aggregation for the second Friday of the month.",!
  1.  S BGPTASK=$$CHKFQT()
  1.  I BGPTASK W !!,"The option is already scheduled to run: TASK # ",BGPTASK," at ",$$HTE^XLFDT($P(^%ZTSK(BGPTASK,0),U,6)),"." D DEL,PAUSE^BGP3DU,XIT^BGP3AUUP Q
  1.  NEW BGPDT,BGPX,BGPY
  1.  S BGPDT=DT
  1.  ;get next "second Friday" in this month
  1.  ;S BGPX=$E(DT,1,5)_"01"  ;first of this month
  1.  S BGPY=0  ;friday counter
  1.  ;S X=DT
  1.  ;D DW^%DTC
  1.  D
  1.  . S BGPDT=$E(DT,1,5)_"01"
  1.  . S X=BGPDT D DW^%DTC I X="FRIDAY" S BGPY=BGPY+1
  1.  . F  D  Q:BGPY=2
  1.  . . S (X,BGPDT)=$$FMADD^XLFDT(BGPDT,1)
  1.  . . D DW^%DTC
  1.  . . Q:X'="FRIDAY"
  1.  . . S BGPY=BGPY+1
  1.  I BGPDT<DT D
  1.  .;ADD 1 TO bgpdt Until the month changs
  1.  .S BGPY=0
  1.  .S BGPDT=DT F  S BGPDT=$$FMADD^XLFDT(BGPDT,1) Q:$E(BGPDT,4,5)'=$E(DT,4,5)
  1.  .S X=BGPDT D DW^%DTC I X="FRIDAY" S BGPY=BGPY+1
  1.  .F  D  Q:BGPY=2
  1.  ..S (X,BGPDT)=$$FMADD^XLFDT(BGPDT,1)
  1.  ..D DW^%DTC
  1.  ..Q:X'="FRIDAY"
  1.  ..S BGPY=BGPY+1
  1.  W !,"This option will be scheduled for ",$$FMTE^XLFDT(BGPDT)," at 12:00pm.",!
  1.  K DIR
  1.  S DIR(0)="Y",DIR("A")="Do you wish to continue and schedule it",DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) Q
  1.  I 'Y Q
  1.  ;S BGPOPT="BGP 13 AUTO PROC SITE FILES"
  1.  ;S BGPOPTD0=$O(^DIC(19,"B",BGPOPT,0))
  1.  ;I 'BGPOPTD0 D  Q
  1.  ;. D BMES^XPDUTL("'BGP 13 AUTO PROC SITE FILES' OPTION NOT FOUND!")
  1.  ;. D PAUSE^BGP3DU
  1.  ;. D XIT^BGP3AUUP
  1.  ;Q:'BGPOPTD0
  1.  ;S BGPD0=$O(^DIC(19.2,"B",BGPOPTD0,0))
  1.  ;D ADDOPT(BGPOPTD0,.BGPD0)
  1.  S BGPX=BGPDT_".12"
  1.  ;D EDITOPT(BGPD0)
  1.  ;ztload
  1.  S ZTDTH=BGPX
  1.  ;S ZTSAVE("BGP*")=""
  1.  S ZTRTN="AUTO^BGP3AUUP"
  1.  S ZTDESC="BGP3 AUTO GPRA AREA AGGREGATE"
  1.  S ZTIO=""
  1.  D ^%ZTLOAD
  1.  S BGPTSK=$G(ZTSK)
  1.  D BMES^XPDUTL("OPTION 'BGP3 AUTO AREA AGGREGATE' SCHEDULED AS TASK #"_BGPTSK)
  1.  D PAUSE^BGP3DU,XIT^BGP3AUUP
  1.  Q
  1. SCHGUI ;EP -- gui scheduler
  1.  NEW BGPDT,BGPX,BGPY
  1.  S BGPDT=DT
  1.  ;get next "second Friday" in this month
  1.  ;S BGPX=$E(DT,1,5)_"01"  ;first of this month
  1.  S BGPY=0  ;friday counter
  1.  ;S X=DT
  1.  ;D DW^%DTC
  1.  D
  1.  . S BGPDT=$E(DT,1,5)_"01"
  1.  . S X=BGPDT D DW^%DTC I X="FRIDAY" S BGPY=BGPY+1
  1.  . F  D  Q:BGPY=2
  1.  . . S (X,BGPDT)=$$FMADD^XLFDT(BGPDT,1)
  1.  . . D DW^%DTC
  1.  . . Q:X'="FRIDAY"
  1.  . . S BGPY=BGPY+1
  1.  I BGPDT<DT D
  1.  .;ADD 1 TO bgpdt Until the month changs
  1.  .S BGPY=0
  1.  .S BGPDT=DT F  S BGPDT=$$FMADD^XLFDT(BGPDT,1) Q:$E(BGPDT,4,5)'=$E(DT,4,5)
  1.  .S X=BGPDT D DW^%DTC I X="FRIDAY" S BGPY=BGPY+1
  1.  .F  D  Q:BGPY=2
  1.  ..S (X,BGPDT)=$$FMADD^XLFDT(BGPDT,1)
  1.  ..D DW^%DTC
  1.  ..Q:X'="FRIDAY"
  1.  ..S BGPY=BGPY+1
  1.  S BGPX=BGPDT_".12"
  1.  ;D EDITOPT(BGPD0)
  1.  ;ztload
  1.  S ZTDTH=BGPX
  1.  ;S ZTSAVE("BGP*")=""
  1.  S ZTRTN="AUTO^BGP3AUUP"
  1.  S ZTDESC="BGP3 AUTO GPRA AREA AGGREGATE"
  1.  S ZTIO=""
  1.  D ^%ZTLOAD
  1.  S BGPTSK=$G(ZTSK)
  1.  Q
  1.  ;
  1. ADDOPT(BGPOPTD0,BGPD0) ;
  1.  ;----- ADD OPTION TO OPTION SCHEDULING FILE
  1.  ;
  1.  N DD,DIC,DO,X,Y
  1.  ;
  1.  S BGPD0=$O(^DIC(19.2,"B",BGPOPTD0,0)) I BGPD0 Q
  1.  S BGPD0=0
  1.  S X=BGPOPTD0
  1.  S DIC="^DIC(19.2,"
  1.  S DIC(0)=""
  1.  D FILE^DICN
  1.  Q:+Y'>0
  1.  S BGPD0=+Y
  1.  Q
  1. EDITOPT(BGPD0) ;
  1.  ;----- EDIT OPTION SCHEDULING OPTION
  1.  ;
  1.  N %DT,%L,%X,%Y,BGPDT,BGPF,DIFROM,D,D0,DA,DI,DIC,DIE,DIE,DQ,DR,X,Y
  1.  ;
  1.  S BGPF="1M"
  1.  S DA=BGPD0
  1.  S DIE="^DIC(19.2,"
  1.  S DR="2///^S X=BGPX;6///^S X=BGPF"
  1.  D ^DIE
  1.  Q
  1. CHKFQT() ;EP - check for queued task (BGP AUTO GPRA EXTRACT and BGPSITE variable within the task
  1.  NEW X,Y,Z,Q
  1.  S Y=$$FMTH^XLFDT(DT)
  1.  S Q=""  ;not found
  1.  S X=0
  1.  F  S X=$O(^%ZTSK(X)) Q:X'=+X  D
  1.  .Q:$P($G(^%ZTSK(X,0)),U,1,2)'="AUTO^BGP3AUUP"
  1.  .Q:$P($G(^%ZTSK(X,.03)),U,1)'="BGP3 AUTO GPRA AREA AGGREGATE"  ;"BGP 13 AUTO GPRA EXTRACT"  ;not the gpra export
  1.  .Q:$P($G(^%ZTSK(X,0)),U,6)<Y
  1.  .S Q=X  ;found it scheduled
  1.  Q Q
  1. DEL ;EP
  1.  K DIR
  1.  S DIR(0)="Y",DIR("A")="Do you wish to Un-Schedule the task",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) W !!,"Task still scheduled." Q
  1.  I 'Y W !!,"Task still scheduled." Q
  1.  D DELTASK^BGP3AUEX
  1.  W !!,"Task Un-Scheduled.",!
  1.  Q