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