source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRINQ.m@ 1154

Last change on this file since 1154 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 3.8 KB
Line 
1PRCPRINQ ;WISC/RFJ-inquire to inventory files ;10 Feb 94
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D ^PRCPUSEL Q:'$G(PRCP("I"))
5 N %,COSTDA,DA,DATETIME,DIC,DIR,DR,GROUPDA,ITEMDA,ORDERDA,PRCPFILE,PRCPFLAG,PRCPPRIV,STOREDA,TRANDA,X,Y
6 S DIR(0)="SO^"
7 F %=2:1 S X=$P($T(FILES+%),";",3,4) Q:X="" I $P(X,";",2)[PRCP("DPTYPE") S DIR(0)=DIR(0)_$P(X,";")_";"
8 S DIR("A")="Select FILE for inquiry"
9 W ! D ^DIR I Y'>444 Q
10 S PRCPFILE=+Y,PRCPPRIV=1
11 ; file 445
12 I PRCPFILE=445 D Q:$G(PRCPFLAG)
13 . S XP="Do you want to see the inventory point parameters",XH="Enter YES to see the inventory point data, NO to just see item data, ^ to exit."
14 . W ! S %=$$YN^PRCPUYN(2) I %'=1 S:%=0 PRCPFLAG=1 Q
15 . W !?10,PRCP("RV1"),"*** I N V E N T O R Y D A T A ***",PRCP("RV0")
16 . N DA,DIC,DR
17 . S DIC="^PRCP(445,",DA=PRCP("I"),DR="0;2;3;4;DEV"
18 . D EN^DIQ
19 ; file 445 and 445.1
20 I PRCPFILE=445!(PRCPFILE=445.1) D Q
21 . F W ! S ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),0,"","") Q:'ITEMDA D
22 . . W !?10,PRCP("RV1"),"*** I N V E N T O R Y P O I N T I T E M D A T A ***",PRCP("RV0")
23 . . N DA,DIC,DR
24 . . S DIC="^PRCP("_PRCPFILE_","_PRCP("I")_",1,",DA=ITEMDA
25 . . D EN^DIQ
26 ; file 445.2
27 I PRCPFILE=445.2 D Q
28 . F W ! S TRANDA=$$SELECT^PRCPUTRS(PRCP("I")) Q:'TRANDA D
29 . . W !?10,PRCP("RV1"),"*** T R A N S A C T I O N R E G I S T E R D A T A ***",PRCP("RV0")
30 . . N DA,DIC,DR
31 . . S DIC="^PRCP(445.2,",DA=TRANDA
32 . . D EN^DIQ
33 ; file 445.3
34 I PRCPFILE=445.3 D Q
35 . F W ! S ORDERDA=$$ORDERSEL^PRCPOPUS(PRCP("I"),0,"*",0) Q:'ORDERDA D
36 . . W !?10,PRCP("RV1"),"*** D I S T R I B U T I O N O R D E R D A T A ***",PRCP("RV0")
37 . . N DA,DIC,DR
38 . . S DIC="^PRCP(445.3,",DA=ORDERDA
39 . . D EN^DIQ
40 ; file 445.4
41 I PRCPFILE=445.4 D Q
42 . F W ! S STOREDA=$$STORE^PRCPESTO(PRCP("I")) Q:'STOREDA D
43 . . W !?10,PRCP("RV1"),"*** S T O R A G E L O C A T I O N D A T A ***",PRCP("RV0")
44 . . N DA,DIC,DR
45 . . S DIC="^PRCP(445.4,",DA=STOREDA
46 . . D EN^DIQ
47 ; file 445.6
48 I PRCPFILE=445.6 D Q
49 . F W ! S GROUPDA=$$GROUP^PRCPEGRP(PRCP("I"),"") Q:'GROUPDA D
50 . . W !?10,PRCP("RV1"),"*** G R O U P C A T E G O R Y D A T A ***",PRCP("RV0")
51 . . N DA,DIC,DR
52 . . S DIC="^PRCP(445.6,",DA=GROUPDA
53 . . D EN^DIQ
54 ; file 445.7
55 I PRCPFILE=445.7 D Q
56 . F W ! S ITEMDA=$$SELECT^PRCPCED0("C",0,PRCP("I")) Q:'ITEMDA D
57 . . W !?10,PRCP("RV1"),"*** C A S E C A R T I T E M D A T A ***",PRCP("RV0")
58 . . N DA,DIC,DR
59 . . S DIC="^PRCP(445.7,",DA=ITEMDA
60 . . D EN^DIQ
61 ; file 445.8
62 I PRCPFILE=445.8 D Q
63 . F W ! S ITEMDA=$$SELECT^PRCPCED0("K",0,PRCP("I")) Q:'ITEMDA D
64 . . W !?10,PRCP("RV1"),"*** I N S T R U M E N T K I T I T E M D A T A ***",PRCP("RV0")
65 . . N DA,DIC,DR
66 . . S DIC="^PRCP(445.8,",DA=ITEMDA
67 . . D EN^DIQ
68 ; file 446
69 I PRCPFILE=446 D Q
70 . F W ! S COSTDA=$$SELCOSTS^PRCPUCC(PRCP("I")) Q:'COSTDA D
71 . . W !?10,PRCP("RV1"),"*** D I S T R I B U T I O N C O S T D A T A ***",PRCP("RV0")
72 . . N DA,DIC,DR
73 . . S DIC="^PRCP(446,",DA=COSTDA
74 . . D EN^DIQ
75 ; file 446.1
76 I PRCPFILE=446.1 D Q
77 . F W ! S DATETIME=$$SELECT^PRCPUPAT Q:'DATETIME D
78 . . W !?10,PRCP("RV1"),"*** P A T I E N T D I S T R I B U T E D S U P P L I E S ***",PRCP("RV0")
79 . . N DA,DIC,DR
80 . . S DIC="^PRCP(446.1,",DA=DATETIME
81 . . D EN^DIQ
82 Q
83 ;
84 ;
85FILES ; list of files to select from
86 ; filenumber:filename;inventory point type allowed
87 ;;445:GENERIC INVENTORY;WPS
88 ;;445.1:INVENTORY BALANCES;WPS
89 ;;445.2:INVENTORY TRANSACTION;WPS
90 ;;445.3:INTERNAL DISTRIBUTION ORDER;P
91 ;;445.4:STORAGE LOCATION;WPS
92 ;;445.6:GROUP CATEGORY;WPS
93 ;;445.7:CASE CARTS;PS
94 ;;445.8:INSTRUMENT KITS;PS
95 ;;446:DISTRIBUTION/USAGE HISTORY;WP
96 ;;446.1:INVENTORY DISTRIBUTED PATIENT SUPPLIES;PS
Note: See TracBrowser for help on using the repository browser.