source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRINQ.m@ 1769

PRCPRINQ ;WISC/RFJ-inquire to inventory files                       ;10 Feb 94

 ;;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 %,COSTDA,DA,DATETIME,DIC,DIR,DR,GROUPDA,ITEMDA,ORDERDA,PRCPFILE,PRCPFLAG,PRCPPRIV,STOREDA,TRANDA,X,Y

 S DIR(0)="SO^"

 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,";")_";"

 S DIR("A")="Select FILE for inquiry"

 W ! D ^DIR I Y'>444 Q

 S PRCPFILE=+Y,PRCPPRIV=1

 ;  file 445

 I PRCPFILE=445 D  Q:$G(PRCPFLAG)

 .   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."

 .   W ! S %=$$YN^PRCPUYN(2) I %'=1 S:%=0 PRCPFLAG=1 Q

 .   W !?10,PRCP("RV1"),"*** I N V E N T O R Y   D A T A ***",PRCP("RV0")

 .   N DA,DIC,DR

 .   S DIC="^PRCP(445,",DA=PRCP("I"),DR="0;2;3;4;DEV"

 .   D EN^DIQ

 ;  file 445 and 445.1

 I PRCPFILE=445!(PRCPFILE=445.1) D  Q

 .   F  W ! S ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),0,"","") Q:'ITEMDA  D

 .   .   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")

 .   .   N DA,DIC,DR

 .   .   S DIC="^PRCP("_PRCPFILE_","_PRCP("I")_",1,",DA=ITEMDA

 .   .   D EN^DIQ

 ;  file 445.2

 I PRCPFILE=445.2 D  Q

 .   F  W ! S TRANDA=$$SELECT^PRCPUTRS(PRCP("I")) Q:'TRANDA  D

 .   .   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")

 .   .   N DA,DIC,DR

 .   .   S DIC="^PRCP(445.2,",DA=TRANDA

 .   .   D EN^DIQ

 ;  file 445.3

 I PRCPFILE=445.3 D  Q

 .   F  W ! S ORDERDA=$$ORDERSEL^PRCPOPUS(PRCP("I"),0,"*",0) Q:'ORDERDA  D

 .   .   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")

 .   .   N DA,DIC,DR

 .   .   S DIC="^PRCP(445.3,",DA=ORDERDA

 .   .   D EN^DIQ

 ;  file 445.4

 I PRCPFILE=445.4 D  Q

 .   F  W ! S STOREDA=$$STORE^PRCPESTO(PRCP("I")) Q:'STOREDA  D

 .   .   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")

 .   .   N DA,DIC,DR

 .   .   S DIC="^PRCP(445.4,",DA=STOREDA

 .   .   D EN^DIQ

 ;  file 445.6

 I PRCPFILE=445.6 D  Q

 .   F  W ! S GROUPDA=$$GROUP^PRCPEGRP(PRCP("I"),"") Q:'GROUPDA  D

 .   .   W !?10,PRCP("RV1"),"*** G R O U P   C A T E G O R Y   D A T A ***",PRCP("RV0")

 .   .   N DA,DIC,DR

 .   .   S DIC="^PRCP(445.6,",DA=GROUPDA

 .   .   D EN^DIQ

 ;  file 445.7

 I PRCPFILE=445.7 D  Q

 .   F  W ! S ITEMDA=$$SELECT^PRCPCED0("C",0,PRCP("I")) Q:'ITEMDA  D

 .   .   W !?10,PRCP("RV1"),"*** C A S E   C A R T   I T E M   D A T A ***",PRCP("RV0")

 .   .   N DA,DIC,DR

 .   .   S DIC="^PRCP(445.7,",DA=ITEMDA

 .   .   D EN^DIQ

 ;  file 445.8

 I PRCPFILE=445.8 D  Q

 .   F  W ! S ITEMDA=$$SELECT^PRCPCED0("K",0,PRCP("I")) Q:'ITEMDA  D

 .   .   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")

 .   .   N DA,DIC,DR

 .   .   S DIC="^PRCP(445.8,",DA=ITEMDA

 .   .   D EN^DIQ

 ;  file 446

 I PRCPFILE=446 D  Q

 .   F  W ! S COSTDA=$$SELCOSTS^PRCPUCC(PRCP("I")) Q:'COSTDA  D

 .   .   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")

 .   .   N DA,DIC,DR

 .   .   S DIC="^PRCP(446,",DA=COSTDA

 .   .   D EN^DIQ

 ;  file 446.1

 I PRCPFILE=446.1 D  Q

 .   F  W ! S DATETIME=$$SELECT^PRCPUPAT Q:'DATETIME  D

 .   .   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")

 .   .   N DA,DIC,DR

 .   .   S DIC="^PRCP(446.1,",DA=DATETIME

 .   .   D EN^DIQ

 Q

 ;

 ;

FILES ;  list of files to select from

 ;  filenumber:filename;inventory point type allowed

 ;;445:GENERIC INVENTORY;WPS

 ;;445.1:INVENTORY BALANCES;WPS

 ;;445.2:INVENTORY TRANSACTION;WPS

 ;;445.3:INTERNAL DISTRIBUTION ORDER;P

 ;;445.4:STORAGE LOCATION;WPS

 ;;445.6:GROUP CATEGORY;WPS

 ;;445.7:CASE CARTS;PS

 ;;445.8:INSTRUMENT KITS;PS

 ;;446:DISTRIBUTION/USAGE HISTORY;WP

 ;;446.1:INVENTORY DISTRIBUTED PATIENT SUPPLIES;PS