source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRC0B.m@ 949

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

initial load of WorldVistAEHR
File size: 4.3 KB
RevLine 
[613]1PRC0B ;WISC/PLT-UTILITY ; 02/03/94 8:36 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 QUIT ; invalid entry
5 ;
6 ;prca = ~1 file number;file root;file record id;field # of multiple for adding
7 ; ~2 subfile number;subfile root (required if subfile);subfile RI;field # of multiple for adding
8 ; ~...
9 ;prcb data ~1=ACEFILMNOQSXZ any combination, ~2=DINUM (option), ~3=SPECIFIED INDEICES
10 ;prcc = select propmt text (optional)
11 ;.x = dir array for lookup specification (optional) and value returned
12 ;.y = value returned from ^dic
13LOOKUP(X,Y,PRCA,PRCB,PRCC) ;entry look-up
14 N %,%Y,DG,DISYS,DIC,DLAYGO,DUPUT,DTOUT,DA,A,B,C,D,I
15 S:PRCA'?.E1"~" PRCA=PRCA_"~" S A=$L(PRCA,"~")-1
16 I A>1 F B=1:1:A-1 S C=$P(PRCA,"~",B),DA(A-B)=$P(C,";",3) S:$P(C,";",4)]"" DIC("P")=$$DICP^PRC0B1(+C,$P(C,";",4))
17 S B=$P(PRCA,"~",A),DIC=$P(B,";",2) S:DIC=""&(A=1) DIC=+B
18 I $D(X)\10 F A=0,"A","B","S","W","DR","P" S:$D(X(A)) DIC(A)=X(A) K X(A)
19 S:$D(PRCC) DIC("A")=PRCC
20 S:'$D(DIC(0)) DIC(0)=$P(PRCB,"~") S:DIC(0)["L" DLAYGO=PRCA
21 S:$P(PRCB,"~",2)?1.N DINUM=$P(PRCB,"~",2)
22 S DA="",D=$P(PRCB,"~",3) I D="" D ^DIC I 1
23 E D MIX^DIC1
24 QUIT
25 ;
26 ;prca = ~1 file number;file root (required if prcc["L");file record id
27 ; ~2 subfile number (option);subfile root;subfile RI
28 ; ~...
29 ;prcb = editing fields string DR if not in x-array (optional)
30 ;prcc = string; '^' abort not allowed if ["^", lock/unlock if ["L"
31 ; single lock/unlock if ["LS"
32 ;.x = editing filed string DR array or value returned
33 ; = value returned 0 if deleted, -1 if abort with '^'
34 ; 1 if normal exit, -2 if lock fail
35EDIT(X,PRCA,PRCB,PRCC) ;edit entry in file
36 N %,%Y,D0,D1,DDH,DISYS,DLAYGO,DQ
37 N DI,DIE,DIC,DIS,DA,DR,PRCLOCK,A,B,C,D,Y
38 S:PRCA'?.E1"~" PRCA=PRCA_"~" S PRCC=$G(PRCC),A=$L(PRCA,"~")-1,PRCLOCK=""
39 I A>1 F B=1:1:A-1 S C=$P(PRCA,"~",B),DA(A-B)=$P(C,";",3)
40 S B=$P(PRCA,"~",A),DIE=$P(B,";",2),DA=$P(B,";",3) S:PRCC["L" PRCLOCK=DIE_$S(PRCC["LS":DA_",",1:"")
41 S:DIE=""&(A=1) DIE=+B
42 S DR=$G(PRCB) S:PRCC["^" DIE("NO^")=""
43 I DR="" S %X="X(",%Y="DR(",DR=X D %XY^%RCR K X
44 K X I PRCLOCK]"" S Y=3 D ICLOCK(PRCLOCK,.Y) I 'Y S X=-2 QUIT
45 D ^DIE,DCLOCK(PRCLOCK):PRCLOCK]""
46 S X=$S('$D(DA):0,$D(Y)=0:1,1:-1)
47 QUIT
48 ;
49 ;prca = ~1 file number;file root (option);file record id
50 ; ~2 subfile number;subfile root (option);subfile RI
51 ; ~...
52 ;prcb = ~1 field#;field#;...
53 ; ~2 subfield #;subfield #;...
54 ; ~...
55 ;prcc = string of characters I, E. (no N) (required)
56 ;prcd = local array name returned, it cann't be %,X,Y
57 ; PRCA,PRCB,PRCD,PRCD,PRCE,PRCF
58 ; @prcd(file#,record id,field #,"E")=external value
59 ; @prcd(file#,record id,field #,"I")=internal value
60PIECE(PRCA,PRCB,PRCC,PRCD) ;get piece data
61 N D0,DIC,DR,DA,DIQ,PRCE,PRCF,DI
62 S PRCE=$P(PRCA,"~"),DIC=+PRCE,DA=$P(PRCE,";",3),DR=$P(PRCB,"~")
63 F PRCF=2:1 Q:$P(PRCA,"~",PRCF)="" S PRCE=$P(PRCA,"~",PRCF),DA(+PRCE)=$P(PRCE,";",3),DR(+PRCE)=$P(PRCB,"~",PRCF)
64 S DIQ=PRCD,DIQ(0)=PRCC_"N"
65 D EN^DIQ1
66 QUIT
67 ;
68 ;prca = (sub)file node root
69 ;prcb = node value
70NODE(PRCA,PRCB) ;get node
71 N PRCC
72 S @("PRCC=$G("_PRCA_"PRCB))")
73 QUIT PRCC
74 ;
75 ;prc is piece #
76NP(PRCA,PRCB,PRCC) ;get node and piece
77 N PRCD
78 S @("PRCD=$P($G("_PRCA_"PRCB)),""^"",PRCC)")
79 QUIT PRCD
80 ;
81 ;extrinsic variable for lookup screen active enteries for sd dic
82 ;$$STATUS^PRC0B = fix value of status file 420.1999
83STATUS() ;get status fix value via pointer of file 420.1999, naked '^' used for lookup screen
84 N A
85 S A=$P($G(^(0)),U,3)
86 QUIT $S(A:$P($G(^PRCD(420.1999,A,0)),U,4),1:"A")
87 ;
88 ;
89 ;
90ICLOCK(A,B) ;incremental lock with time (optional)
91 ; a = global root ending with ','
92 ; .b = time lock seconds and value returned; false if lock fail
93 S A=$E(A,1,$L(A)-1)
94 I $D(B) L +@(A_")"):B S B=$T E QUIT
95 S PRCLOCK(A)=$G(PRCLOCK(A))+1
96 I '$D(B) S B=99999999 L +@(A_")"):B
97 QUIT
98 ;
99DCLOCK(A) ;decremental unlock
100 ; a = global root ending with ','
101 S A=$E(A,1,$L(A)-1)
102 L -@(A_")") S PRCLOCK(A)=$G(PRCLOCK(A))-1 K:PRCLOCK(A)<1 PRCLOCK(A)
103 QUIT
104 ;
105UNLOCK(A) ;unlock all ^PRC(A)
106 ; a = global root ending with ','
107 S A=$E(A,1,$L(A)-1)
108 F Q:$G(PRCLOCK(A))<1 L -@(A_")") S PRCLOCK(A)=$G(PRCLOCK(A))-1
109 K PRCLOCK(A)
110 QUIT
111 ;
112UNLKALL ;unlock all ^PRC
113 N A
114 S A="" F S A=$O(PRCLOCK(A)) Q:A="" F Q:$G(PRCLOCK(A))<1 L -@(A_")") S PRCLOCK(A)=$G(PRCLOCK(A))-1
115 K PRCLOCK
116 QUIT
117 ;
Note: See TracBrowser for help on using the repository browser.