Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRSU1B

PRSU1B.m

Go to the documentation of this file. 
  1. PRSU1B ;WOIFO/PLT-UTILITY ; 24-Aug-2005 10:34 AM
  1.  ;;4.0;PAID;**126**;Sep 21, 1995;Build 59
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  QUIT  ; invalid entry
  1.  ;
  1.  ;prsa = ~1 file number;file root;file record id;field # of multiple for adding
  1.  ;       ~2 subfile number;subfile root (required if subfile);subfile RI;field # of multiple for adding
  1.  ;       ~...
  1.  ;prsb data ~1=ABCEFIKLMNnOQSTUVXZ any combination
  1.  ;A:ask entry, B:B index only when .01 is pointer, C:display same enty more than one time
  1.  ;E:echo back for user interactive mode, F:not save in disv for reuse
  1.  ;I:ignore special look-up routine, K:use uniqueness key index, L:add new entry
  1.  ;M:use all indices, N:use ien to lookup if no matches, n:include numeric in free text field
  1.  ;O:exact match search first, partial second for all indices
  1.  ;Q:error with ??, S:suppress disply if one match found
  1.  ;T:continue all search results until '^' entered, U: use interanl format value search 
  1.  ;V:ask ok if 1 match found, X:exact match
  1.  ;Z:zero node y(0) and external format y(0,0) returned
  1.  ;  ~2=DINUM (option), ~3=SPECIFIED INDEICES
  1.  ;prsc = select prompt text (optional)
  1.  ;.x = dir array for lookup specification (optional) and value returned
  1.  ;.y = value returned from ^dic
  1. LOOKUP(X,Y,PRSA,PRSB,PRSC) ;entry look-up
  1.  N %,%Y,DG,DISYS,DIC,DLAYGO,DUPUT,DTOUT,DA,A,B,C,D,I
  1.  S:PRSA'?.E1"~" PRSA=PRSA_"~" S A=$L(PRSA,"~")-1
  1.  I A>1 F B=1:1:A-1 S C=$P(PRSA,"~",B),DA(A-B)=$P(C,";",3)
  1.  S B=$P(PRSA,"~",A),DIC=$P(B,";",2)  S:DIC=""&(A=1) DIC=+B
  1.  I $D(X)\10 F A=0,"A","B","S","W","DR","P" S:$D(X(A)) DIC(A)=X(A) K X(A)
  1.  S:$D(PRSC) DIC("A")=PRSC
  1.  S:'$D(DIC(0)) DIC(0)=$P(PRSB,"~") S:DIC(0)["L" DLAYGO=PRSA
  1.  S:$P(PRSB,"~",2)?1.N DINUM=$P(PRSB,"~",2)
  1.  S DA="",D=$P(PRSB,"~",3) I D="" D ^DIC I 1
  1.  E  D MIX^DIC1
  1.  QUIT
  1.  ;
  1.  ;prsa = ~1 file number;file root (required if prsc["L");file record id
  1.  ;       ~2 subfile number (option);subfile root;subfile RI
  1.  ;       ~...
  1.  ;prsb = editing fields string DR if not in x-array (optional)
  1.  ;prsc = string; '^' abort not allowed if ["^", lock/unlock if ["L"
  1.  ;          single lock/unlock if ["LS"
  1.  ;.x = editing filed string DR array or value returned
  1.  ;   = value returned 0 if deleted, -1 if abort with '^'
  1.  ;                    1 if normal exit, -2 if lock fail
  1. EDIT(X,PRSA,PRSB,PRSC) ;edit entry in file
  1.  N %,%Y,D0,D1,DDH,DISYS,DLAYGO,DQ
  1.  N DI,DIE,DIC,DIS,DA,DR,PRSLOCK,A,B,C,D,Y
  1.  S:PRSA'?.E1"~" PRSA=PRSA_"~" S PRSC=$G(PRSC),A=$L(PRSA,"~")-1,PRSLOCK=""
  1.  I A>1 F B=1:1:A-1 S C=$P(PRSA,"~",B),DA(A-B)=$P(C,";",3)
  1.  S B=$P(PRSA,"~",A),DIE=$P(B,";",2),DA=$P(B,";",3) S:PRSC["L" PRSLOCK=DIE_$S(PRSC["LS":DA_",",1:"")
  1.  S:DIE=""&(A=1) DIE=+B
  1.  S DR=$G(PRSB) S:PRSC["^" DIE("NO^")=""
  1.  I DR="" S %X="X(",%Y="DR(",DR=X D %XY^%RCR K X
  1.  K X I PRSLOCK]"" S Y=3 D ICLOCK(PRSLOCK,.Y) I 'Y S X=-2 QUIT
  1.  D ^DIE,DCLOCK(PRSLOCK):PRSLOCK]""
  1.  S X=$S('$D(DA):0,$D(Y)=0:1,1:-1)
  1.  QUIT
  1.  ;
  1.  ;prsa = ~1 file number;file root (option);file record id
  1.  ;       ~2 subfile number;subfile root (option);subfile RI
  1.  ;       ~...
  1.  ;prsb = ~1 field#;field#;...
  1.  ;       ~2 subfield #;subfield #;...
  1.  ;       ~...
  1.  ;prsc = string of characters I, E. (no N) (required)
  1.  ;prsd = local array name returned, it cann't be %,X,Y
  1.  ;        PRSA,PRSB,PRSD,PRSD,PRSE,PRSF
  1.  ;     @prsd(file#,record id,field #,"E")=external value
  1.  ;     @prsd(file#,record id,field #,"I")=internal value
  1. PIECE(PRSA,PRSB,PRSC,PRSD) ;get piece data
  1.  N D0,DIC,DR,DA,DIQ,PRSE,PRSF,DI
  1.  S PRSE=$P(PRSA,"~"),DIC=+PRSE,DA=$P(PRSE,";",3),DR=$P(PRSB,"~")
  1.  F PRSF=2:1 Q:$P(PRSA,"~",PRSF)=""  S PRSE=$P(PRSA,"~",PRSF),DA(+PRSE)=$P(PRSE,";",3),DR(+PRSE)=$P(PRSB,"~",PRSF)
  1.  S DIQ=PRSD,DIQ(0)=PRSC_"N"
  1.  D EN^DIQ1
  1.  QUIT
  1.  ;
  1.  ;prsa = (sub)file node root
  1.  ;prsb = node value
  1. NODE(PRSA,PRSB) ;get node
  1.  N PRSC
  1.  S @("PRSC=$G("_PRSA_"PRSB))")
  1.  QUIT PRSC
  1.  ;
  1.  ;prsc is piece #
  1. NP(PRSA,PRSB,PRSC) ;get node and piece
  1.  N PRSD
  1.  S @("PRSD=$P($G("_PRSA_"PRSB)),""^"",PRSC)")
  1.  QUIT PRSD
  1.  ;
  1.  ;
  1.  ;
  1.  ;prslock array used to store lock history
  1. ICLOCK(A,B) ;incremental lock with time (optional)
  1.  ;  a = global root ending with ',' or '('
  1.  ; .b = time lock seconds and value returned; false if lock fail
  1.  S A=$E(A,1,$L(A)-1) I A["(" S A=A_")"
  1.  I $D(B) L +@(A):B S B=$T E  QUIT
  1.  S PRSLOCK(A)=$G(PRSLOCK(A))+1
  1.  I '$D(B) S B=99999999 L +@(A):B
  1.  QUIT
  1.  ;
  1. DCLOCK(A) ;decremental unlock a from prslock array of locking history
  1.  ;  a = global root ending with ',' or '('
  1.  S A=$E(A,1,$L(A)-1) I A["(" S A=A_")"
  1.  L -@(A) S PRSLOCK(A)=$G(PRSLOCK(A))-1 K:PRSLOCK(A)<1 PRSLOCK(A)
  1.  QUIT
  1.  ;
  1. UNLOCK(A) ;unlock a file (to decremental to 0) in prslock(a)
  1.  ;  a = global root ending with ',' or '('
  1.  S A=$E(A,1,$L(A)-1) I A["(" S A=A_")"
  1.  F  Q:$G(PRSLOCK(A))<1  L -@(A) S PRSLOCK(A)=$G(PRSLOCK(A))-1
  1.  K PRSLOCK(A)
  1.  QUIT
  1.  ;
  1. UNLKALL ;unlock all files in prslock array
  1.  N A
  1.  S A="" F  S A=$O(PRSLOCK(A)) Q:A=""  F  Q:$G(PRSLOCK(A))<1  L -@(A) S PRSLOCK(A)=$G(PRSLOCK(A))-1
  1.  K PRSLOCK
  1.  QUIT
  1.  ;