source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUTRS.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 4.0 KB
Line 
1PRCPUTRS ;WISC/RFJ-transaction history file selection ;07 Jul 92
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7SELECT(PRCPINPT) ; select transaction register entry for inventory point
8 N DA,PIECES,PRCPFLAG,X,Y
9 D INFOHELP
10 ;
11 F D Q:$G(PRCPFLAG)
12 . W !,"Select TRANSACTION REGISTER entry: "
13 . R X:DTIME S:'$T X="^" I X["^" S X="^",PRCPFLAG=1 Q
14 . I X="" S PRCPFLAG=1 Q
15 . I X["?" D HELP(""),INFOHELP Q
16 . S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
17 . ; lookup by trans id
18 . I "RUACSPE"[$E(X),$D(^PRCP(445.2,"T",PRCPINPT,X)) S DA=$$SHOW("^PRCP(445.2,""T"","_PRCPINPT_","""_X_""",") S:DA PRCPFLAG=1 Q
19 . I $E($O(^PRCP(445.2,"T",PRCPINPT,X)))=$E(X) D HELP(X),INFOHELP Q
20 . ;
21 . ; lookup by voucher number
22 . I $D(^PRCP(445.2,"V",X)) S DA=$$SHOW("^PRCP(445.2,""V"","""_X_""",") S:DA PRCPFLAG=1 Q
23 . ;
24 . ; lookup by transaction number
25 . S PIECES=$L(X,"-")
26 . I $L($P(X,"-",PIECES))=4 D
27 . . I PIECES=5 Q
28 . . I PIECES=4 S X=PRC("SITE")_"-"_X
29 . . I PIECES=3 S X=PRC("SITE")_"-"_PRC("FY")_"-"_X Q
30 . . I PIECES=2 S X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_X
31 . I $L(X,"-")=1 S X=PRC("SITE")_"-"_X
32 . I $D(^PRCP(445.2,"C",X)) S DA=$$SHOW("^PRCP(445.2,""C"","""_X_""",") S:DA PRCPFLAG=1 Q
33 . W ?65,"invalid entry"
34 S X=$G(^PRCP(445.2,+$G(DA),0))
35 I X'="" S Y=$P(X,"^",3) W !,"selected: ",$P(X,"^",2),?20,$P(X,"^",19),?40,$P(X,"^",15),?50,$E(Y,4,5),"-",$E(Y,6,7),"-",$E(Y,2,3),?60,"IM#",$P(X,"^",5),?70,$E($$DESCR^PRCPUX1(PRCPINPT,+$P(X,"^",5)),1,9)
36 Q +$G(DA)
37 ;
38 ;
39SHOW(GLOBAL) ; present list of matches to user
40 N DA,DATA,ENDLINE,LINE,PRCPFLAG,SELECTDA,STARTLIN,Y
41 K ^TMP($J,"PRCPUTRS")
42 S LINE=0,DA=0
43 F D Q:$G(PRCPFLAG)
44 . S STARTLIN=LINE+1 F S DA=$O(@(GLOBAL_DA_")")) Q:'DA I $P($G(^PRCP(445.2,DA,0)),"^")=PRCPINPT S LINE=LINE+1,^TMP($J,"PRCPUTRS",LINE)=DA Q:LINE#15=0
45 . I '$D(^TMP($J,"PRCPUTRS",STARTLIN)) S PRCPFLAG=1 Q
46 . ; one entry only
47 . I LINE=1 S SELECTDA=^TMP($J,"PRCPUTRS",1),PRCPFLAG=1 Q
48 . ;
49 . W !!?2,"ENTRY",?10,"TRANID",?20,"TRANSACTION",?40,"VOUCHER",?50,"DATE",?60,"ITEM"
50 . F ENDLINE=STARTLIN:1 Q:'$D(^TMP($J,"PRCPUTRS",ENDLINE)) S DATA=$G(^PRCP(445.2,+^TMP($J,"PRCPUTRS",ENDLINE),0)) I DATA'="" D
51 . . S Y=$P(DATA,"^",3)
52 . . W !?2,ENDLINE,?10,$P(DATA,"^",2),?20,$P(DATA,"^",19),?40,$P(DATA,"^",15),?50,$E(Y,4,5),"-",$E(Y,6,7),"-",$E(Y,2,3),?60,"IM#",$P(DATA,"^",5),?70,$E($$DESCR^PRCPUX1(PRCPINPT,+$P(DATA,"^",5)),1,9)
53 . I 'DA W !?2,"--- end of list ---"
54 . ;
55 . W !!,"Select an ENTRY from the list (from 1 to ",ENDLINE-1,"): "
56 . R X:DTIME I '$T!(X["^") S PRCPFLAG=1 Q
57 . I $D(^TMP($J,"PRCPUTRS",+X)) S SELECTDA=^(+X),PRCPFLAG=1 Q
58 . ;
59 . ; entire list displayed
60 . I 'DA S PRCPFLAG=1
61 K ^TMP($J,"PRCPUTRS")
62 Q +$G(SELECTDA)
63 ;
64 ;
65INFOHELP ; display info help text
66 N HELP
67 S HELP(1)="You may lookup entries in the TRANSACTION REGISTER file by selecting: A) the transaction register id (A123 or RC456, etc); B) the transaction number which is the 2237, issue book, or purchase order number"
68 S HELP(2)="(460-94-2-120-0010 or 120-0010 if its the same quarter and year or purchase order G12345); C) the voucher number (I400001)."
69 W ! D DISPLAY^PRCPUX2(2,76,.HELP)
70 Q
71 ;
72 ;
73HELP(Y) ; display help (if Y="" ask start with)
74 N DATA,DIR,LINE,PRCPFLAG,TRANID,X
75 I Y="" D I Y'="A",Y'="R",Y'="RC",Y'="C",Y'="U",Y'="P",Y'="S",Y'="E" Q
76 . S DIR(0)="S0^A:adjustment;RC:receipt;R:distribution regular;C:distribution call-in;E:distribution emergency;U:usage;P:physical count;S:case cart/instrument kit assembly or disassembly;"
77 . S DIR("A")=" Start HELP with entry type",DIR("B")="adjustment"
78 . D ^DIR
79 ;
80 ; show tranid entries
81 S TRANID=Y F LINE=1:1 S TRANID=$O(^PRCP(445.2,"T",PRCPINPT,TRANID)) Q:TRANID="" D I LINE#15=0 D P^PRCPUREP Q:$G(PRCPFLAG)
82 . S DATA=$G(^PRCP(445.2,+$O(^PRCP(445.2,"T",PRCPINPT,TRANID,0)),0)),Y=$P(DATA,"^",3)
83 . W !?2,"tranid:",?10,$P(DATA,"^",2),?20,$P(DATA,"^",19),?40,$P(DATA,"^",15),?50,$E(Y,4,5),"-",$E(Y,6,7),"-",$E(Y,2,3)
84 Q
Note: See TracBrowser for help on using the repository browser.