ACRFT25H ;IHS/OIRM/DSD/AEF - FIND TRAVEL VOUCHERS > $2500 [ 09/26/2005 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
;
;
DESC ;----- ROUTINE DESCRIPTION
;;
;;This routine will loop through the travel vouchers and find all
;;those that total more than $2500.00 for the date range specified.
;;The resulting report shows the document number, traveler name,
;;departure date, return date, CAN number, department account, and
;;amount claimed.
;;
;;$$END
Q
;
EN ;----- MAIN ENTRY POINT
;
N ACRDATES,ACROUT,ZTDESC,ZTRTN,ZTSAVE,X,Y
;
D ^XBKVAR
D HOME^%ZIS
;
D TXT
;
D DATES(.ACRDATES,.ACROUT)
Q:ACROUT
;
S ZTRTN="DQ^ACRFT25H"
S ZTSAVE("ACRDATES")=""
S ZTDESC="TRAVEL ORDERS EXCEEDING $2500"
D QUE^ACRFUTL(ZTRTN,.ZTSAVE,.ZTDESC)
;
Q
DATES(ACRDATES,ACROUT) ;
;----- ASK BEGINNING TRAVEL DATE RANGE
;
DLOOP ;----- DATE LOOP
;
N ACRBEG,ACREND,DIR,DIRUT,DTOUT,DUOUT,X,Y
W !
S ACROUT=1
S DIR(0)="DO^::E"
S DIR("A")="Begin with DATE OF DEPARTURE"
S DIR("?")="The date to be included in the date range"
D ^DIR
Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))
Q:Y=""
S ACRBEG=Y
S DIR("A")="End with DATE OF DEPARTURE"
D ^DIR
Q:$D(DTOUT)!($D(DTOUT))!($D(DIRUT))
Q:Y=""
S ACREND=Y_".999999"
I ACREND<ACRBEG D G DLOOP
. W *7,!?5,"ENDING DATE cannot be less than BEGINNING DATE"
S ACRDATES=ACRBEG_U_ACREND
S ACROUT=0
Q
DQ ;EP -- QUEUED REPORT STARTS HERE
;
D GET(ACRDATES)
D PRINT(ACRDATES)
K ^TMP("ACR",$J,"TVL2500")
D ^%ZISC
Q
GET(ACRDATES) ;
;----- LOOP THROUGH "REF" CROSSREFERENCE
; GATHER DATA AND PUT INTO ^TMP("ACR",$J,"TVL2500" GLOBAL
;
N ACRAMT,ACRBEG,ACRCAN,ACRDEPT,ACRDOC0,ACRDOCDA,ACRDOCNO,ACRDTBEG,ACRDTEND,ACREND,ACRFY,ACRREF,ACRTO,ACRTRAV
K ^TMP("ACR",$J,"TVL2500")
S ACRREF=$O(^AUTTDOCR("B",600,0))
Q:'ACRREF
S ACRBEG=$P(ACRDATES,U)
S ACREND=$P(ACRDATES,U,2)
;
S ACRDOCDA=0
F S ACRDOCDA=$O(^ACRDOC("REF",ACRREF,ACRDOCDA)) Q:'ACRDOCDA D
. Q:$P($G(^ACRDOC(ACRDOCDA,0)),U,14)["CANCEL"
. S ACRDTBEG=$P($G(^ACRDOC(ACRDOCDA,"TO")),U,14)
. Q:ACRDTBEG<ACRBEG
. Q:ACRDTBEG>ACREND
. S ACRDOC0=$G(^ACRDOC(ACRDOCDA,0))
. S ACRDOCNO=$P(ACRDOC0,U)
. S ACRTO=$G(^ACRDOC(ACRDOCDA,"TO"))
. S ACRTRAV=$P(ACRTO,U,9)
. ;I ACRTRAV S ACRTRAV=$P($G(^VA(200,ACRTRAV,0)),U) ;ACR*2.1*19.02 IM16848
. I ACRTRAV S ACRTRAV=$$NAME2^ACRFUTL1(ACRTRAV) ;ACR*2.1*19.02 IM16848
. S ACRDTBEG=$P(ACRTO,U,14)
. I ACRDTBEG]"" S ACRDTBEG=$E(ACRDTBEG,4,5)_"/"_$E(ACRDTBEG,6,7)_"/"_$E(ACRDTBEG,2,3)
. S ACRDTEND=$P(ACRTO,U,15)
. I ACRDTEND]"" S ACRDTEND=$E(ACRDTEND,4,5)_"/"_$E(ACRDTEND,6,7)_"/"_$E(ACRDTEND,2,3)
. S ACRAMT=$$TOTAMT^ACRFSSU(ACRDOCDA)
. S ACRCAN=$P($G(^ACRDOC(ACRDOCDA,"REQ")),U,10)
. I ACRCAN S ACRCAN=$P($G(^AUTTCAN(ACRCAN,0)),U)
. S ACRDEPT=$P(ACRDOC0,U,6)
. S ACRFY=""
. I ACRDEPT S ACRFY=$P($G(^ACRLOCB(ACRDEPT,"DT")),U)
. S ^TMP("ACR",$J,"TVL2500",$E(ACRDOCNO,1,10),1_$E(ACRDOCNO,11,13))=ACRDOCNO_U_ACRTRAV_U_ACRDTBEG_U_ACRDTEND_U_ACRCAN_U_ACRDEPT_U_ACRFY_U_ACRAMT
. S ^TMP("ACR",$J,"TVL2500",$E(ACRDOCNO,1,10),0)=$G(^TMP("ACR",$J,"TVL2500",$E(ACRDOCNO,1,10),0))+ACRAMT
Q
;
PRINT(ACRDATES) ;
;----- LOOP THROUGH ^TMP("ACR",$J,"TVL2500" GLOBAL AND PRINT REPORT
;
N ACR,ACRDATA,ACRDOCNO,ACROUT,ACRPAGE,ACRZ
D HDR(ACRDATES,.ACROUT,.ACRPAGE)
S ACRZ=1
S ACRDOCNO=""
F S ACRDOCNO=$O(^TMP("ACR",$J,"TVL2500",ACRDOCNO)) Q:ACRDOCNO']"" D Q:$G(ACROUT)
. Q:^TMP("ACR",$J,"TVL2500",ACRDOCNO,0)<2500
. S ACRZ=0
. S ACR=0
. F S ACR=$O(^TMP("ACR",$J,"TVL2500",ACRDOCNO,ACR)) Q:'ACR D Q:$G(ACROUT)
. . S ACRDATA=^TMP("ACR",$J,"TVL2500",ACRDOCNO,ACR)
. . I $Y>(IOSL-5) D HDR(ACRDATES,.ACROUT,.ACRPAGE)
. . Q:$G(ACROUT)
. . W !
. . W $P(ACRDATA,U)
. . W ?15,$E($P(ACRDATA,U,2),1,15)
. . W ?31,$P(ACRDATA,U,3)
. . W ?40,$P(ACRDATA,U,4)
. . W ?49,$P(ACRDATA,U,5)
. . W ?57,$J($P(ACRDATA,U,6),6)
. . W ?64,$P(ACRDATA,U,7)
. . W ?68,$J($P(ACRDATA,U,8),12,2)
. W !?72,"--------"
. W !?61,"TOTAL"
. W ?68,$J(^TMP("ACR",$J,"TVL2500",ACRDOCNO,0),12,2)
. W !
I ACRZ D
. W !?5,"NO DATA FOUND"
Q
HDR(ACRDATES,ACROUT,ACRPAGE) ;
;----- PRINT REPORT HEADER
;
N DIR,X
S ACROUT=0
I $E($G(IOST))="C",$G(ACRPAGE) D Q:$G(ACROUT)
. S DIR(0)="E"
. D ^DIR
. I 'Y S ACROUT=1
S ACRPAGE=$G(ACRPAGE)+1
;
W @IOF
W !,"TRAVEL VOUCHERS EXCEEDING $2500, "
S X=$P(ACRDATES,U)
W $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
W "-"
S X=$P(ACRDATES,U,2)
W $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
W ?52,$$NOW^ACRFUTL
W " PAGE ",$G(ACRPAGE)
W !,"TRAVEL"
W ?31,"DEPART"
W ?40,"RETURN"
W ?49,"CAN"
W ?59,"DEPT"
W ?64,"FY"
W !,"VOUCHER NO."
W ?15,"TRAVELER"
W ?31,"DATE"
W ?40,"DATE"
W ?49,"NO."
W ?59,"ACCT"
W ?64,"FUNDS"
W ?74,"AMOUNT"
W !
F I=1:1:80 W "-"
Q
TXT ;----- WRITE ROUTINE DESCRIPTION
;
N I
F I=1:1 S X=$P($T(DESC+I),";",3) Q:X["$$END" W !,X
Q
ACRFT25H ;IHS/OIRM/DSD/AEF - FIND TRAVEL VOUCHERS > $2500 [ 09/26/2005 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
+2 ;
+3 ;
DESC ;----- ROUTINE DESCRIPTION
+1 ;;
+2 ;;This routine will loop through the travel vouchers and find all
+3 ;;those that total more than $2500.00 for the date range specified.
+4 ;;The resulting report shows the document number, traveler name,
+5 ;;departure date, return date, CAN number, department account, and
+6 ;;amount claimed.
+7 ;;
+8 ;;$$END
+9 QUIT
+10 ;
EN ;----- MAIN ENTRY POINT
+1 ;
+2 NEW ACRDATES,ACROUT,ZTDESC,ZTRTN,ZTSAVE,X,Y
+3 ;
+4 DO ^XBKVAR
+5 DO HOME^%ZIS
+6 ;
+7 DO TXT
+8 ;
+9 DO DATES(.ACRDATES,.ACROUT)
+10 IF ACROUT
QUIT
+11 ;
+12 SET ZTRTN="DQ^ACRFT25H"
+13 SET ZTSAVE("ACRDATES")=""
+14 SET ZTDESC="TRAVEL ORDERS EXCEEDING $2500"
+15 DO QUE^ACRFUTL(ZTRTN,.ZTSAVE,.ZTDESC)
+16 ;
+17 QUIT
DATES(ACRDATES,ACROUT) ;
+1 ;----- ASK BEGINNING TRAVEL DATE RANGE
+2 ;
DLOOP ;----- DATE LOOP
+1 ;
+2 NEW ACRBEG,ACREND,DIR,DIRUT,DTOUT,DUOUT,X,Y
+3 WRITE !
+4 SET ACROUT=1
+5 SET DIR(0)="DO^::E"
+6 SET DIR("A")="Begin with DATE OF DEPARTURE"
+7 SET DIR("?")="The date to be included in the date range"
+8 DO ^DIR
+9 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
QUIT
+10 IF Y=""
QUIT
+11 SET ACRBEG=Y
+12 SET DIR("A")="End with DATE OF DEPARTURE"
+13 DO ^DIR
+14 IF $DATA(DTOUT)!($DATA(DTOUT))!($DATA(DIRUT))
QUIT
+15 IF Y=""
QUIT
+16 SET ACREND=Y_".999999"
+17 IF ACREND<ACRBEG
Begin DoDot:1
+18 WRITE *7,!?5,"ENDING DATE cannot be less than BEGINNING DATE"
End DoDot:1
GOTO DLOOP
+19 SET ACRDATES=ACRBEG_U_ACREND
+20 SET ACROUT=0
+21 QUIT
DQ ;EP -- QUEUED REPORT STARTS HERE
+1 ;
+2 DO GET(ACRDATES)
+3 DO PRINT(ACRDATES)
+4 KILL ^TMP("ACR",$JOB,"TVL2500")
+5 DO ^%ZISC
+6 QUIT
GET(ACRDATES) ;
+1 ;----- LOOP THROUGH "REF" CROSSREFERENCE
+2 ; GATHER DATA AND PUT INTO ^TMP("ACR",$J,"TVL2500" GLOBAL
+3 ;
+4 NEW ACRAMT,ACRBEG,ACRCAN,ACRDEPT,ACRDOC0,ACRDOCDA,ACRDOCNO,ACRDTBEG,ACRDTEND,ACREND,ACRFY,ACRREF,ACRTO,ACRTRAV
+5 KILL ^TMP("ACR",$JOB,"TVL2500")
+6 SET ACRREF=$ORDER(^AUTTDOCR("B",600,0))
+7 IF 'ACRREF
QUIT
+8 SET ACRBEG=$PIECE(ACRDATES,U)
+9 SET ACREND=$PIECE(ACRDATES,U,2)
+10 ;
+11 SET ACRDOCDA=0
+12 FOR
SET ACRDOCDA=$ORDER(^ACRDOC("REF",ACRREF,ACRDOCDA))
IF 'ACRDOCDA
QUIT
Begin DoDot:1
+13 IF $PIECE($GET(^ACRDOC(ACRDOCDA,0)),U,14)["CANCEL"
QUIT
+14 SET ACRDTBEG=$PIECE($GET(^ACRDOC(ACRDOCDA,"TO")),U,14)
+15 IF ACRDTBEG<ACRBEG
QUIT
+16 IF ACRDTBEG>ACREND
QUIT
+17 SET ACRDOC0=$GET(^ACRDOC(ACRDOCDA,0))
+18 SET ACRDOCNO=$PIECE(ACRDOC0,U)
+19 SET ACRTO=$GET(^ACRDOC(ACRDOCDA,"TO"))
+20 SET ACRTRAV=$PIECE(ACRTO,U,9)
+21 ;I ACRTRAV S ACRTRAV=$P($G(^VA(200,ACRTRAV,0)),U) ;ACR*2.1*19.02 IM16848
+22 ;ACR*2.1*19.02 IM16848
IF ACRTRAV
SET ACRTRAV=$$NAME2^ACRFUTL1(ACRTRAV)
+23 SET ACRDTBEG=$PIECE(ACRTO,U,14)
+24 IF ACRDTBEG]""
SET ACRDTBEG=$EXTRACT(ACRDTBEG,4,5)_"/"_$EXTRACT(ACRDTBEG,6,7)_"/"_$EXTRACT(ACRDTBEG,2,3)
+25 SET ACRDTEND=$PIECE(ACRTO,U,15)
+26 IF ACRDTEND]""
SET ACRDTEND=$EXTRACT(ACRDTEND,4,5)_"/"_$EXTRACT(ACRDTEND,6,7)_"/"_$EXTRACT(ACRDTEND,2,3)
+27 SET ACRAMT=$$TOTAMT^ACRFSSU(ACRDOCDA)
+28 SET ACRCAN=$PIECE($GET(^ACRDOC(ACRDOCDA,"REQ")),U,10)
+29 IF ACRCAN
SET ACRCAN=$PIECE($GET(^AUTTCAN(ACRCAN,0)),U)
+30 SET ACRDEPT=$PIECE(ACRDOC0,U,6)
+31 SET ACRFY=""
+32 IF ACRDEPT
SET ACRFY=$PIECE($GET(^ACRLOCB(ACRDEPT,"DT")),U)
+33 SET ^TMP("ACR",$JOB,"TVL2500",$EXTRACT(ACRDOCNO,1,10),1_$EXTRACT(ACRDOCNO,11,13))=ACRDOCNO_U_ACRTRAV_U_ACRDTBEG_U_ACRDTEND_U_ACRCAN_U_ACRDEPT_U_ACRFY_U_ACRAMT
+34 SET ^TMP("ACR",$JOB,"TVL2500",$EXTRACT(ACRDOCNO,1,10),0)=$GET(^TMP("ACR",$JOB,"TVL2500",$EXTRACT(ACRDOCNO,1,10),0))+ACRAMT
End DoDot:1
+35 QUIT
+36 ;
PRINT(ACRDATES) ;
+1 ;----- LOOP THROUGH ^TMP("ACR",$J,"TVL2500" GLOBAL AND PRINT REPORT
+2 ;
+3 NEW ACR,ACRDATA,ACRDOCNO,ACROUT,ACRPAGE,ACRZ
+4 DO HDR(ACRDATES,.ACROUT,.ACRPAGE)
+5 SET ACRZ=1
+6 SET ACRDOCNO=""
+7 FOR
SET ACRDOCNO=$ORDER(^TMP("ACR",$JOB,"TVL2500",ACRDOCNO))
IF ACRDOCNO']""
QUIT
Begin DoDot:1
+8 IF ^TMP("ACR",$JOB,"TVL2500",ACRDOCNO,0)<2500
QUIT
+9 SET ACRZ=0
+10 SET ACR=0
+11 FOR
SET ACR=$ORDER(^TMP("ACR",$JOB,"TVL2500",ACRDOCNO,ACR))
IF 'ACR
QUIT
Begin DoDot:2
+12 SET ACRDATA=^TMP("ACR",$JOB,"TVL2500",ACRDOCNO,ACR)
+13 IF $Y>(IOSL-5)
DO HDR(ACRDATES,.ACROUT,.ACRPAGE)
+14 IF $GET(ACROUT)
QUIT
+15 WRITE !
+16 WRITE $PIECE(ACRDATA,U)
+17 WRITE ?15,$EXTRACT($PIECE(ACRDATA,U,2),1,15)
+18 WRITE ?31,$PIECE(ACRDATA,U,3)
+19 WRITE ?40,$PIECE(ACRDATA,U,4)
+20 WRITE ?49,$PIECE(ACRDATA,U,5)
+21 WRITE ?57,$JUSTIFY($PIECE(ACRDATA,U,6),6)
+22 WRITE ?64,$PIECE(ACRDATA,U,7)
+23 WRITE ?68,$JUSTIFY($PIECE(ACRDATA,U,8),12,2)
End DoDot:2
IF $GET(ACROUT)
QUIT
+24 WRITE !?72,"--------"
+25 WRITE !?61,"TOTAL"
+26 WRITE ?68,$JUSTIFY(^TMP("ACR",$JOB,"TVL2500",ACRDOCNO,0),12,2)
+27 WRITE !
End DoDot:1
IF $GET(ACROUT)
QUIT
+28 IF ACRZ
Begin DoDot:1
+29 WRITE !?5,"NO DATA FOUND"
End DoDot:1
+30 QUIT
HDR(ACRDATES,ACROUT,ACRPAGE) ;
+1 ;----- PRINT REPORT HEADER
+2 ;
+3 NEW DIR,X
+4 SET ACROUT=0
+5 IF $EXTRACT($GET(IOST))="C"
IF $GET(ACRPAGE)
Begin DoDot:1
+6 SET DIR(0)="E"
+7 DO ^DIR
+8 IF 'Y
SET ACROUT=1
End DoDot:1
IF $GET(ACROUT)
QUIT
+9 SET ACRPAGE=$GET(ACRPAGE)+1
+10 ;
+11 WRITE @IOF
+12 WRITE !,"TRAVEL VOUCHERS EXCEEDING $2500, "
+13 SET X=$PIECE(ACRDATES,U)
+14 WRITE $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+15 WRITE "-"
+16 SET X=$PIECE(ACRDATES,U,2)
+17 WRITE $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+18 WRITE ?52,$$NOW^ACRFUTL
+19 WRITE " PAGE ",$GET(ACRPAGE)
+20 WRITE !,"TRAVEL"
+21 WRITE ?31,"DEPART"
+22 WRITE ?40,"RETURN"
+23 WRITE ?49,"CAN"
+24 WRITE ?59,"DEPT"
+25 WRITE ?64,"FY"
+26 WRITE !,"VOUCHER NO."
+27 WRITE ?15,"TRAVELER"
+28 WRITE ?31,"DATE"
+29 WRITE ?40,"DATE"
+30 WRITE ?49,"NO."
+31 WRITE ?59,"ACCT"
+32 WRITE ?64,"FUNDS"
+33 WRITE ?74,"AMOUNT"
+34 WRITE !
+35 FOR I=1:1:80
WRITE "-"
+36 QUIT
TXT ;----- WRITE ROUTINE DESCRIPTION
+1 ;
+2 NEW I
+3 FOR I=1:1
SET X=$PIECE($TEXT(DESC+I),";",3)
IF X["$$END"
QUIT
WRITE !,X
+4 QUIT
