ACRFT25H.m

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