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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRINQ 4007 printed Nov 22, 2024@17:25:03 Page 2
PRCPRINQ ;WISC/RFJ-inquire to inventory files ;10 Feb 94
+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 %,COSTDA,DA,DATETIME,DIC,DIR,DR,GROUPDA,ITEMDA,ORDERDA,PRCPFILE,PRCPFLAG,PRCPPRIV,STOREDA,TRANDA,X,Y
+5 SET DIR(0)="SO^"
+6 FOR %=2:1
SET X=$PIECE($TEXT(FILES+%),";",3,4)
if X=""
QUIT
IF $PIECE(X,";",2)[PRCP("DPTYPE")
SET DIR(0)=DIR(0)_$PIECE(X,";")_";"
+7 SET DIR("A")="Select FILE for inquiry"
+8 WRITE !
DO ^DIR
IF Y'>444
QUIT
+9 SET PRCPFILE=+Y
SET PRCPPRIV=1
+10 ; file 445
+11 IF PRCPFILE=445
Begin DoDot:1
+12 SET XP="Do you want to see the inventory point parameters"
SET XH="Enter YES to see the inventory point data, NO to just see item data, ^ to exit."
+13 WRITE !
SET %=$$YN^PRCPUYN(2)
IF %'=1
if %=0
SET PRCPFLAG=1
QUIT
+14 WRITE !?10,PRCP("RV1"),"*** I N V E N T O R Y D A T A ***",PRCP("RV0")
+15 NEW DA,DIC,DR
+16 SET DIC="^PRCP(445,"
SET DA=PRCP("I")
SET DR="0;2;3;4;DEV"
+17 DO EN^DIQ
End DoDot:1
if $GET(PRCPFLAG)
QUIT
+18 ; file 445 and 445.1
+19 IF PRCPFILE=445!(PRCPFILE=445.1)
Begin DoDot:1
+20 FOR
WRITE !
SET ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),0,"","")
if 'ITEMDA
QUIT
Begin DoDot:2
+21 WRITE !?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")
+22 NEW DA,DIC,DR
+23 SET DIC="^PRCP("_PRCPFILE_","_PRCP("I")_",1,"
SET DA=ITEMDA
+24 DO EN^DIQ
End DoDot:2
End DoDot:1
QUIT
+25 ; file 445.2
+26 IF PRCPFILE=445.2
Begin DoDot:1
+27 FOR
WRITE !
SET TRANDA=$$SELECT^PRCPUTRS(PRCP("I"))
if 'TRANDA
QUIT
Begin DoDot:2
+28 WRITE !?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")
+29 NEW DA,DIC,DR
+30 SET DIC="^PRCP(445.2,"
SET DA=TRANDA
+31 DO EN^DIQ
End DoDot:2
End DoDot:1
QUIT
+32 ; file 445.3
+33 IF PRCPFILE=445.3
Begin DoDot:1
+34 FOR
WRITE !
SET ORDERDA=$$ORDERSEL^PRCPOPUS(PRCP("I"),0,"*",0)
if 'ORDERDA
QUIT
Begin DoDot:2
+35 WRITE !?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")
+36 NEW DA,DIC,DR
+37 SET DIC="^PRCP(445.3,"
SET DA=ORDERDA
+38 DO EN^DIQ
End DoDot:2
End DoDot:1
QUIT
+39 ; file 445.4
+40 IF PRCPFILE=445.4
Begin DoDot:1
+41 FOR
WRITE !
SET STOREDA=$$STORE^PRCPESTO(PRCP("I"))
if 'STOREDA
QUIT
Begin DoDot:2
+42 WRITE !?10,PRCP("RV1"),"*** S T O R A G E L O C A T I O N D A T A ***",PRCP("RV0")
+43 NEW DA,DIC,DR
+44 SET DIC="^PRCP(445.4,"
SET DA=STOREDA
+45 DO EN^DIQ
End DoDot:2
End DoDot:1
QUIT
+46 ; file 445.6
+47 IF PRCPFILE=445.6
Begin DoDot:1
+48 FOR
WRITE !
SET GROUPDA=$$GROUP^PRCPEGRP(PRCP("I"),"")
if 'GROUPDA
QUIT
Begin DoDot:2
+49 WRITE !?10,PRCP("RV1"),"*** G R O U P C A T E G O R Y D A T A ***",PRCP("RV0")
+50 NEW DA,DIC,DR
+51 SET DIC="^PRCP(445.6,"
SET DA=GROUPDA
+52 DO EN^DIQ
End DoDot:2
End DoDot:1
QUIT
+53 ; file 445.7
+54 IF PRCPFILE=445.7
Begin DoDot:1
+55 FOR
WRITE !
SET ITEMDA=$$SELECT^PRCPCED0("C",0,PRCP("I"))
if 'ITEMDA
QUIT
Begin DoDot:2
+56 WRITE !?10,PRCP("RV1"),"*** C A S E C A R T I T E M D A T A ***",PRCP("RV0")
+57 NEW DA,DIC,DR
+58 SET DIC="^PRCP(445.7,"
SET DA=ITEMDA
+59 DO EN^DIQ
End DoDot:2
End DoDot:1
QUIT
+60 ; file 445.8
+61 IF PRCPFILE=445.8
Begin DoDot:1
+62 FOR
WRITE !
SET ITEMDA=$$SELECT^PRCPCED0("K",0,PRCP("I"))
if 'ITEMDA
QUIT
Begin DoDot:2
+63 WRITE !?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")
+64 NEW DA,DIC,DR
+65 SET DIC="^PRCP(445.8,"
SET DA=ITEMDA
+66 DO EN^DIQ
End DoDot:2
End DoDot:1
QUIT
+67 ; file 446
+68 IF PRCPFILE=446
Begin DoDot:1
+69 FOR
WRITE !
SET COSTDA=$$SELCOSTS^PRCPUCC(PRCP("I"))
if 'COSTDA
QUIT
Begin DoDot:2
+70 WRITE !?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")
+71 NEW DA,DIC,DR
+72 SET DIC="^PRCP(446,"
SET DA=COSTDA
+73 DO EN^DIQ
End DoDot:2
End DoDot:1
QUIT
+74 ; file 446.1
+75 IF PRCPFILE=446.1
Begin DoDot:1
+76 FOR
WRITE !
SET DATETIME=$$SELECT^PRCPUPAT
if 'DATETIME
QUIT
Begin DoDot:2
+77 WRITE !?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")
+78 NEW DA,DIC,DR
+79 SET DIC="^PRCP(446.1,"
SET DA=DATETIME
+80 DO EN^DIQ
End DoDot:2
End DoDot:1
QUIT
+81 QUIT
+82 ;
+83 ;
FILES ; list of files to select from
+1 ; filenumber:filename;inventory point type allowed
+2 ;;445:GENERIC INVENTORY;WPS
+3 ;;445.1:INVENTORY BALANCES;WPS
+4 ;;445.2:INVENTORY TRANSACTION;WPS
+5 ;;445.3:INTERNAL DISTRIBUTION ORDER;P
+6 ;;445.4:STORAGE LOCATION;WPS
+7 ;;445.6:GROUP CATEGORY;WPS
+8 ;;445.7:CASE CARTS;PS
+9 ;;445.8:INSTRUMENT KITS;PS
+10 ;;446:DISTRIBUTION/USAGE HISTORY;WP
+11 ;;446.1:INVENTORY DISTRIBUTED PATIENT SUPPLIES;PS
