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

ADEPSUB.m

Go to the documentation of this file. 
  1. ADEPSUB ; IHS/HQT/MJL  -SUBROUTINE & FUNCTION LIBRARY ;05:06 PM  [ 03/24/1999   9:04 AM ]
  1.  ;;6.0;ADE;;APRIL 1999
  1.  ;
  1.  ;SUBROUTINES AND $$FUNCTIONS FOR ADEP REPORTS
  1.  ;
  1. MDATE ;EP - MONTHLY REPORTS
  1.  ;Prompts for Beginning Month
  1.  ;Returns date range in ADEDATE and ADEWK1, 2, & 3 variables
  1.  N ADECNT,ADEX,ADEBEG,ADEJ
  1.  S ADEDATE=$$MMONTH()
  1.  S ADEBEG=$P(ADEDATE,U,2)
  1.  S ADECNT=0
  1.  F ADEJ="07","14","21" S ADECNT=ADECNT+1,ADEX="ADEWK"_ADECNT,@ADEX=$E(ADEBEG,1,5)_ADEJ
  1.  Q
  1.  ;
  1. MMONTH() ;EP - Returns "1 or 0^Begin^End"
  1.  N DIR,ADEBEG,X,Y,ADEND
  1.  W ! S DIR("A")="Report will cover which month (MONTH-YR): "
  1.  S DIR(0)="DA^2810101:"_DT_":E"
  1. MDAT1 D ^DIR
  1.  Q:$$HAT^ADEPQA() 0
  1.  S ADEBEG=Y
  1.  I $E(ADEBEG,6,7)'="00" W !?5,"Please enter only the month and year" G MDAT1
  1.  S ADEND=$E(ADEBEG,4,5)+1,ADEND="00"_ADEND,ADEND=$E(ADEND,$L(ADEND)-1,$L(ADEND)),ADEND=$E(ADEBEG,1,3)_ADEND_"00"
  1.  Q "1^"_ADEBEG_U_ADEND
  1.  ;
  1.  ;
  1. QDATE ;EP - DATE PROCESSING FOR QUARTERLY REPORTS
  1.  N ADECNT,ADEX,ADEBEG,ADEJ
  1.  S ADEDATE=$$QMONTH()
  1.  S ADEBEG=$P(ADEDATE,U,2)
  1.  S ADECNT=0
  1.  ;F ADEJ="07","14","21" S ADECNT=ADECNT+1,ADEX="ADEWK"_ADECNT,@ADEX=$E(ADEBEG,1,5)_ADEJ
  1.  F ADEJ=1:1:2 S ADECNT=ADECNT+1,ADEX="ADEWK"_ADECNT D
  1.  . N ADEWK,ADETMP
  1.  . S ADEWK=ADEBEG
  1.  . ;beginning Y2K fix
  1.  . ;S ADETMP="00"_($E(ADEWK,4,5)+ADEJ)
  1.  . ;S ADETMP=$E(ADETMP,$L(ADETMP)-1,$L(ADETMP))
  1.  . ;S $E(ADEWK,4,5)=ADETMP
  1.  . ;I $E(ADEWK,4,5)=13 S $E(ADEWK,2,3)=$E(ADEWK,2,3)+1,$E(ADEWK,4,5)="01"
  1.  . ;I $E(ADEWK,4,5)=14 S $E(ADEWK,2,3)=$E(ADEWK,2,3)+1,$E(ADEWK,4,5)="02"
  1.  .S ADETMP=$E(ADEWK,4,5)+ADEJ  ;Y2000
  1.  .I ADETMP<13 S $E(ADEWK,4,5)=$S($L(ADETMP)=1:"0"_ADETMP,1:ADETMP)  ;Y2000
  1.  .I ADETMP=13 S $E(ADEWK,1,3)=$E(ADEWK,1,3)+1,$E(ADEWK,4,5)="01"  ;Y2000
  1.  .I ADETMP=14 S $E(ADEWK,1,3)=$E(ADEWK,1,3)+1,$E(ADEWK,4,5)="02"  ;Y2000
  1.  . ;end Y2K fix block
  1.  . S @ADEX=ADEWK
  1.  Q
  1.  ;
  1. QMONTH() ;EP Returns "1 or 0^Begin^End"
  1.  N DIR,ADEBEG,X,Y,ADEND,ADENDY
  1.  W ! S DIR("A")="Report will cover 3 month period beginning (MONTH-YR): "
  1.  S DIR(0)="DA^2810101:"_DT_":E"
  1. QDAT1 D ^DIR
  1.  Q:$$HAT^ADEPQA() 0
  1.  S ADEBEG=Y
  1.  I $E(ADEBEG,6,7)'="00" W !?5,"Please enter only the month and year" G QDAT1
  1.  S ADEND=$E(ADEBEG,4,5)
  1.  ;beginning Y2K fix
  1.  ;I ADEND>9 S ADEND=ADEND-9
  1.  ;E  S ADEND=ADEND+3
  1.  ;S ADEND="00"_ADEND
  1.  ;S ADEND=$E(ADEND,$L(ADEND)-1,$L(ADEND))
  1.  ;S ADENDY=$E(ADEBEG,2,3)
  1.  ;S:$E(ADEBEG,4,5)>9 ADENDY=ADENDY+1
  1.  ;S ADEND=2_ADENDY_ADEND_"00"
  1.  S ADENDM=$S(ADEND>9:ADEND-9,1:ADEND+3)  ;Y2000
  1.  S ADENDY=$S(ADEND>9:$E(ADEBEG,1,3)+1,1:$E(ADEBEG,1,3))  ;Y2000
  1.  S ADEND=ADENDY_$S($L(ADENDM)=1:"0"_ADENDM,1:ADENDM)_"00"  ;Y2000
  1.  ;end Y2K fix block
  1.  Q "1^"_ADEBEG_U_ADEND
  1.  ;
  1.  ;
  1. YDATE ;EP - DATE PROCESSING FOR ANNUAL REPORTS
  1.  N ADECNT,ADEX,ADEBEG,ADEJ
  1.  S ADEDATE=$$YMONTH()
  1.  S ADEBEG=$P(ADEDATE,U,2)
  1.  S ADECNT=0
  1.  F ADEJ=3:3:9 S ADECNT=ADECNT+1,ADEX="ADEWK"_ADECNT D
  1.  . N ADEWK,ADETMP
  1.  . S ADEWK=ADEBEG
  1.  . S ADETMP="00"_($E(ADEWK,4,5)+ADEJ)
  1.  . S ADETMP=$E(ADETMP,$L(ADETMP)-1,$L(ADETMP))
  1.  . S $E(ADEWK,4,5)=ADETMP
  1.  . I $E(ADEWK,4,5)>12 D
  1.  . . N ADEMO
  1.  . . S $E(ADEWK,1,3)=$E(ADEWK,1,3)+1
  1.  . . S ADEMO=$E(ADEWK,4,5)
  1.  . . S ADEMO=ADEMO#12
  1.  . . S ADEMO="00"_ADEMO
  1.  . . S ADEMO=$E(ADEMO,$L(ADEMO)-1,$L(ADEMO))
  1.  . . S $E(ADEWK,4,5)=ADEMO
  1.  . . K ADEMO
  1.  . S @ADEX=ADEWK
  1.  Q
  1.  ;
  1. YMONTH() ;EP Returns "1 or 0^Begin^End"
  1.  N DIR,ADEBEG,X,Y,ADEND,ADENDY
  1.  W ! S DIR("A")="Report will cover 12 month period beginning (MONTH-YR): "
  1.  S DIR(0)="DA^2810101:"_DT_":E"
  1. YDAT1 D ^DIR
  1.  Q:$$HAT^ADEPQA() 0
  1.  S ADEBEG=Y
  1.  I $E(ADEBEG,6,7)'="00" W !?5,"Please enter only the month and year" G YDAT1
  1.  S ADEND=ADEBEG
  1.  S $E(ADEND,1,3)=$E(ADEBEG,1,3)+1
  1.  Q "1^"_ADEBEG_U_ADEND
  1.  ;
  1. ADEU() ;GET UNIQUE SUBSCRIPT NUMBER AND LOCK REPORT NODE
  1.  ;RETURNS SUBSCRIPT NUMBER
  1.  S ADEU=$J
  1. ADEU1 F  L +^TMP("ADEP",ADEU):.1 Q:$T  S ADEU=ADEU+1
  1.  I $G(^TMP("ADEP",ADEU))="RUNNING" L -^TMP("ADEP",ADEU) S ADEU=ADEU+1 G ADEU1
  1.  Q ADEU
  1.  ;
  1. ASKDEV(ADERTN,ADEDESC) ;EP - DEVICE SELECTION
  1.  ;ADERTN=PROCESSING ROUTINE ENTRY POINT
  1.  ;ADEDESC=DESCRIPTION
  1.  K ADEIOP,IOP,ZTSK,ADEIOPAR
  1.  W !!,"Enter 'Q' at the DEVICE prompt to queue this report to run in the background."
  1.  S %ZIS="NQ"
  1.  D ^%ZIS
  1.  Q:POP
  1.  S ADEIOP=ION_";"_IOM_";"_IOSL
  1.  S ADEIOPAR=IOPAR
  1.  Q:'$D(IO("Q"))
  1.  D QUE
  1.  ;FHL 9/9/98 I '$D(ZTSK) K IOP,ADEIOP G ASKDEV
  1.  I '$D(ZTQUEUED) K IOP,ADEIOP G ASKDEV
  1.  D HOME^%ZIS
  1.  W !,"REPORT IS QUEUED!"
  1.  Q
  1.  ;
  1. QUE ;
  1.  N ADEJ
  1.  S ZTRTN=ADERTN
  1.  S ZTDESC=ADEDESC
  1.  F ADEJ="ADEIOP","ADEIOPAR","ADEDATE","ADEWK1","ADEWK2","ADEU" S ZTSAVE(ADEJ)=""
  1.  I $D(ADEWK3) S ZTSAVE("ADEWK3")=""
  1.  S ZTSAVE("ADEHYG")=""
  1.  S ZTSAVE("ADEHNAM(")=""
  1.  I $D(ADEDDS) D
  1.  . S ZTSAVE("ADEDDS")=""
  1.  . S ZTSAVE("ADEDNAM(")=""
  1.  S ZTIO=""
  1.  I $D(IO("HFSIO")) D
  1.  . S ZTIO=ADEIOP
  1.  D ^%ZTLOAD
  1.  Q
  1.  ;
  1. PRINT(FLDS,ADEDHD) ;EP
  1.  I $D(ZTQUEUED) L +^TMP("ADEP",ADEU):1 I '$T S ADENOLOK=1 G PRNEND
  1.  N DIC,BY,ADED0,ADED1,ADED2,ADED3,Y,DHD
  1.  S IOP=ADEIOP
  1.  S %ZIS("IOPAR")=ADEIOPAR
  1.  D ^%ZIS
  1.  S IOP=ADEIOP
  1.  S %ZIS("IOPAR")=ADEIOPAR
  1.  S DIC="^ADEDUM(",BY="@NUMBER",(FR,TO)=""
  1.  S DHD=$O(^ADEPARAM(0)),DHD=$P(^ADEPARAM(DHD,0),U),DHD=$P(^DIC(4,DHD,0),U)
  1.  S DHD=DHD_ADEDHD
  1.  S Y=$P(ADEDATE,U,2) X ^DD("DD")
  1.  S DHD=DHD_" BEGINNING "_Y
  1.  S (ADED0,ADED1,ADED2)=0
  1.  ;FHL 9/9/98 I $D(ZTSK) S ADEZTSK=ZTSK K ZTSK
  1.  I $D(ZTQUEUED) S ADEZTSK=ZTSK K ZTSK
  1.  D EN1^DIP
  1.  I $D(ADEZTSK) S ZTSK=ADEZTSK
  1. PRNEND I $D(ZTQUEUED) S ZTREQ="@"
  1.  I '$D(ADENOLOK) K ^TMP("ADEP",ADEU)
  1.  K ADENOLOK
  1.  Q