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