- 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 ---[H[J[2J[HPRCPRDCR 1709 printed Feb 18, 2025@23:41:07 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