PRCPRDCR.m

PRCPRDCR ;WISC/RFJ-dietetics cost report                            ;27 May 93

 ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 D ^PRCPUSEL Q:'$G(PRCP("I"))

 N %,%H,%I,DATEEND,DATESTRT,INVPT,PRCPFLAG,PRCPIN,X,Y

 K X S X(1)="The Dietetic Cost Report is sorted by the inventory point (selectable), food group from the item master file, NSN, and date received (selectable)." D DISPLAY^PRCPUX2(40,79,.X)

 K X S X(1)="You can select multiple dietetic inventory points for printing this report.  A dietetic inventory point is defined as a primary inventory point with the first two digits of the department number equal to '11'."

 D DISPLAY^PRCPUX2(5,40,.X)

 K ^TMP($J,"PRCPRDIE") S PRCPIN=PRCP("IN")

 S PRCPIN="" I $E($P($G(^PRCP(445,PRCP("I"),0)),"^",8),1,2)="11" S PRCPIN=PRCP("IN")

 F  S INVPT=$$INVPT^PRCPUINV(PRC("SITE"),"P",0,1,PRCPIN) S:INVPT["^" PRCPFLAG=1 Q:'INVPT  D

 .   S PRCPIN=""

 .   I $E($P($G(^PRCP(445,+INVPT,0)),"^",8),1,2)'="11" W !?2,"CANNOT BE SELECTED.  FIRST TWO DIGITS OF DEPARTMENT NUMBER NOT EQUAL TO '11'." Q

 .   S ^TMP($J,"PRCPRDIE",INVPT)=""

 I $G(PRCPFLAG) D Q Q

 I '$O(^TMP($J,"PRCPRDIE",0)) Q

 W !

 K X S X(1)="Select the range of RECEIPT DATES to display" W !! D DISPLAY^PRCPUX2(5,40,.X)

 D DATESEL^PRCPURS2("Receipt") I '$G(DATEEND) D Q Q

 W ! S %ZIS="Q" D ^%ZIS G:POP Q I $D(IO("Q")) D  D ^%ZTLOAD K IO("Q"),ZTSK D Q Q

 .   S ZTDESC="Dietetic Cost Report",ZTRTN="DQ^PRCPRDCR"

 .   S ZTSAVE("PRCP*")="",ZTSAVE("DATE*")="",ZTSAVE("^TMP($J,""PRCPRDIE"",")="",ZTSAVE("ZTREQ")="@"

 W !!,"<*> please wait <*>"

DQ ;  queue starts here

 D START^PRCPRDC0

Q D ^%ZISC K ^TMP($J,"PRCPRDIE"),^TMP($J,"PRCPRDIET")

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCPRDCR   1709     printed  Apr 09, 2024@21:17:41                                                                                                                                                                                                    Page 2

PRCPRDCR  ;WISC/RFJ-dietetics cost report                            ;27 May 93

 +1       ;;5.1;IFCAP;;Oct 20, 2000

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3        DO ^PRCPUSEL

           if '$GET(PRCP("I"))

               QUIT 

 +4        NEW %,%H,%I,DATEEND,DATESTRT,INVPT,PRCPFLAG,PRCPIN,X,Y

 +5        KILL X

           SET X(1)="The Dietetic Cost Report is sorted by the inventory point (selectable), food group from the item master file, NSN, and date received (selectable)."

           DO DISPLAY^PRCPUX2(40,79,.X)

 +6        KILL X

           SET X(1)="You can select multiple dietetic inventory points for printing this report.  A dietetic inventory point is defined as a primary inventory point with the first two digits of the department number equal to '11'."

 +7        DO DISPLAY^PRCPUX2(5,40,.X)

 +8        KILL ^TMP($JOB,"PRCPRDIE")

           SET PRCPIN=PRCP("IN")

 +9        SET PRCPIN=""

           IF $EXTRACT($PIECE($GET(^PRCP(445,PRCP("I"),0)),"^",8),1,2)="11"

               SET PRCPIN=PRCP("IN")

 +10       FOR 

               SET INVPT=$$INVPT^PRCPUINV(PRC("SITE"),"P",0,1,PRCPIN)

               if INVPT["^"

                   SET PRCPFLAG=1

               if 'INVPT

                   QUIT 

               Begin DoDot:1

 +11               SET PRCPIN=""

 +12               IF $EXTRACT($PIECE($GET(^PRCP(445,+INVPT,0)),"^",8),1,2)'="11"

                       WRITE !?2,"CANNOT BE SELECTED.  FIRST TWO DIGITS OF DEPARTMENT NUMBER NOT EQUAL TO '11'."

                       QUIT 

 +13               SET ^TMP($JOB,"PRCPRDIE",INVPT)=""

               End DoDot:1

 +14       IF $GET(PRCPFLAG)

               DO Q

               QUIT 

 +15       IF '$ORDER(^TMP($JOB,"PRCPRDIE",0))

               QUIT 

 +16       WRITE !

 +17       KILL X

           SET X(1)="Select the range of RECEIPT DATES to display"

           WRITE !!

           DO DISPLAY^PRCPUX2(5,40,.X)

 +18       DO DATESEL^PRCPURS2("Receipt")

           IF '$GET(DATEEND)

               DO Q

               QUIT 

 +19       WRITE !

           SET %ZIS="Q"

           DO ^%ZIS

           if POP

               GOTO Q

           IF $DATA(IO("Q"))

               Begin DoDot:1

 +20               SET ZTDESC="Dietetic Cost Report"

                   SET ZTRTN="DQ^PRCPRDCR"

 +21               SET ZTSAVE("PRCP*")=""

                   SET ZTSAVE("DATE*")=""

                   SET ZTSAVE("^TMP($J,""PRCPRDIE"",")=""

                   SET ZTSAVE("ZTREQ")="@"

               End DoDot:1

               DO ^%ZTLOAD

               KILL IO("Q"),ZTSK

               DO Q

               QUIT 

 +22       WRITE !!,"<*> please wait <*>"

DQ        ;  queue starts here

 +1        DO START^PRCPRDC0

Q          DO ^%ZISC

           KILL ^TMP($JOB,"PRCPRDIE"),^TMP($JOB,"PRCPRDIET")

 +1        QUIT