PRC0B ;WISC/PLT-UTILITY ; 02/03/94 8:36 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
QUIT ; invalid entry
;
;prca = ~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
; ~...
;prcb data ~1=ACEFILMNOQSXZ any combination, ~2=DINUM (option), ~3=SPECIFIED INDEICES
;prcc = select propmt text (optional)
;.x = dir array for lookup specification (optional) and value returned
;.y = value returned from ^dic
LOOKUP(X,Y,PRCA,PRCB,PRCC) ;entry look-up
N %,%Y,DG,DISYS,DIC,DLAYGO,DUPUT,DTOUT,DA,A,B,C,D,I
S:PRCA'?.E1"~" PRCA=PRCA_"~" S A=$L(PRCA,"~")-1
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))
S B=$P(PRCA,"~",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(PRCC) DIC("A")=PRCC
S:'$D(DIC(0)) DIC(0)=$P(PRCB,"~") S:DIC(0)["L" DLAYGO=PRCA
S:$P(PRCB,"~",2)?1.N DINUM=$P(PRCB,"~",2)
S DA="",D=$P(PRCB,"~",3) I D="" D ^DIC I 1
E D MIX^DIC1
QUIT
;
;prca = ~1 file number;file root (required if prcc["L");file record id
; ~2 subfile number (option);subfile root;subfile RI
; ~...
;prcb = editing fields string DR if not in x-array (optional)
;prcc = 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,PRCA,PRCB,PRCC) ;edit entry in file
N %,%Y,D0,D1,DDH,DISYS,DLAYGO,DQ
N DI,DIE,DIC,DIS,DA,DR,PRCLOCK,A,B,C,D,Y
S:PRCA'?.E1"~" PRCA=PRCA_"~" S PRCC=$G(PRCC),A=$L(PRCA,"~")-1,PRCLOCK=""
I A>1 F B=1:1:A-1 S C=$P(PRCA,"~",B),DA(A-B)=$P(C,";",3)
S B=$P(PRCA,"~",A),DIE=$P(B,";",2),DA=$P(B,";",3) S:PRCC["L" PRCLOCK=DIE_$S(PRCC["LS":DA_",",1:"")
S:DIE=""&(A=1) DIE=+B
S DR=$G(PRCB) S:PRCC["^" DIE("NO^")=""
I DR="" S %X="X(",%Y="DR(",DR=X D %XY^%RCR K X
K X I PRCLOCK]"" S Y=3 D ICLOCK(PRCLOCK,.Y) I 'Y S X=-2 QUIT
D ^DIE,DCLOCK(PRCLOCK):PRCLOCK]""
S X=$S('$D(DA):0,$D(Y)=0:1,1:-1)
QUIT
;
;prca = ~1 file number;file root (option);file record id
; ~2 subfile number;subfile root (option);subfile RI
; ~...
;prcb = ~1 field#;field#;...
; ~2 subfield #;subfield #;...
; ~...
;prcc = string of characters I, E. (no N) (required)
;prcd = local array name returned, it cann't be %,X,Y
; PRCA,PRCB,PRCD,PRCD,PRCE,PRCF
; @prcd(file#,record id,field #,"E")=external value
; @prcd(file#,record id,field #,"I")=internal value
PIECE(PRCA,PRCB,PRCC,PRCD) ;get piece data
N D0,DIC,DR,DA,DIQ,PRCE,PRCF,DI
S PRCE=$P(PRCA,"~"),DIC=+PRCE,DA=$P(PRCE,";",3),DR=$P(PRCB,"~")
F PRCF=2:1 Q:$P(PRCA,"~",PRCF)="" S PRCE=$P(PRCA,"~",PRCF),DA(+PRCE)=$P(PRCE,";",3),DR(+PRCE)=$P(PRCB,"~",PRCF)
S DIQ=PRCD,DIQ(0)=PRCC_"N"
D EN^DIQ1
QUIT
;
;prca = (sub)file node root
;prcb = node value
NODE(PRCA,PRCB) ;get node
N PRCC
S @("PRCC=$G("_PRCA_"PRCB))")
QUIT PRCC
;
;prc is piece #
NP(PRCA,PRCB,PRCC) ;get node and piece
N PRCD
S @("PRCD=$P($G("_PRCA_"PRCB)),""^"",PRCC)")
QUIT PRCD
;
;extrinsic variable for lookup screen active enteries for sd dic
;$$STATUS^PRC0B = fix value of status file 420.1999
STATUS() ;get status fix value via pointer of file 420.1999, naked '^' used for lookup screen
N A
S A=$P($G(^(0)),U,3)
QUIT $S(A:$P($G(^PRCD(420.1999,A,0)),U,4),1:"A")
;
;
;
ICLOCK(A,B) ;incremental lock with time (optional)
; a = global root ending with ','
; .b = time lock seconds and value returned; false if lock fail
S A=$E(A,1,$L(A)-1)
I $D(B) L +@(A_")"):B S B=$T E QUIT
S PRCLOCK(A)=$G(PRCLOCK(A))+1
I '$D(B) S B=99999999 L +@(A_")"):B
QUIT
;
DCLOCK(A) ;decremental unlock
; a = global root ending with ','
S A=$E(A,1,$L(A)-1)
L -@(A_")") S PRCLOCK(A)=$G(PRCLOCK(A))-1 K:PRCLOCK(A)<1 PRCLOCK(A)
QUIT
;
UNLOCK(A) ;unlock all ^PRC(A)
; a = global root ending with ','
S A=$E(A,1,$L(A)-1)
F Q:$G(PRCLOCK(A))<1 L -@(A_")") S PRCLOCK(A)=$G(PRCLOCK(A))-1
K PRCLOCK(A)
QUIT
;
UNLKALL ;unlock all ^PRC
N A
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
K PRCLOCK
QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC0B 4498 printed Apr 09, 2024@21:18:32 Page 2
PRC0B ;WISC/PLT-UTILITY ; 02/03/94 8:36 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ; invalid entry
QUIT
+3 ;
+4 ;prca = ~1 file number;file root;file record id;field # of multiple for adding
+5 ; ~2 subfile number;subfile root (required if subfile);subfile RI;field # of multiple for adding
+6 ; ~...
+7 ;prcb data ~1=ACEFILMNOQSXZ any combination, ~2=DINUM (option), ~3=SPECIFIED INDEICES
+8 ;prcc = select propmt text (optional)
+9 ;.x = dir array for lookup specification (optional) and value returned
+10 ;.y = value returned from ^dic
LOOKUP(X,Y,PRCA,PRCB,PRCC) ;entry look-up
+1 NEW %,%Y,DG,DISYS,DIC,DLAYGO,DUPUT,DTOUT,DA,A,B,C,D,I
+2 if PRCA'?.E1"~"
SET PRCA=PRCA_"~"
SET A=$LENGTH(PRCA,"~")-1
+3 IF A>1
FOR B=1:1:A-1
SET C=$PIECE(PRCA,"~",B)
SET DA(A-B)=$PIECE(C,";",3)
if $PIECE(C,";",4)]""
SET DIC("P")=$$DICP^PRC0B1(+C,$PIECE(C,";",4))
+4 SET B=$PIECE(PRCA,"~",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(PRCC)
SET DIC("A")=PRCC
+7 if '$DATA(DIC(0))
SET DIC(0)=$PIECE(PRCB,"~")
if DIC(0)["L"
SET DLAYGO=PRCA
+8 if $PIECE(PRCB,"~",2)?1.N
SET DINUM=$PIECE(PRCB,"~",2)
+9 SET DA=""
SET D=$PIECE(PRCB,"~",3)
IF D=""
DO ^DIC
IF 1
+10 IF '$TEST
DO MIX^DIC1
+11 QUIT
+12 ;
+13 ;prca = ~1 file number;file root (required if prcc["L");file record id
+14 ; ~2 subfile number (option);subfile root;subfile RI
+15 ; ~...
+16 ;prcb = editing fields string DR if not in x-array (optional)
+17 ;prcc = 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,PRCA,PRCB,PRCC) ;edit entry in file
+1 NEW %,%Y,D0,D1,DDH,DISYS,DLAYGO,DQ
+2 NEW DI,DIE,DIC,DIS,DA,DR,PRCLOCK,A,B,C,D,Y
+3 if PRCA'?.E1"~"
SET PRCA=PRCA_"~"
SET PRCC=$GET(PRCC)
SET A=$LENGTH(PRCA,"~")-1
SET PRCLOCK=""
+4 IF A>1
FOR B=1:1:A-1
SET C=$PIECE(PRCA,"~",B)
SET DA(A-B)=$PIECE(C,";",3)
+5 SET B=$PIECE(PRCA,"~",A)
SET DIE=$PIECE(B,";",2)
SET DA=$PIECE(B,";",3)
if PRCC["L"
SET PRCLOCK=DIE_$SELECT(PRCC["LS":DA_",",1:"")
+6 if DIE=""&(A=1)
SET DIE=+B
+7 SET DR=$GET(PRCB)
if PRCC["^"
SET DIE("NO^")=""
+8 IF DR=""
SET %X="X("
SET %Y="DR("
SET DR=X
DO %XY^%RCR
KILL X
+9 KILL X
IF PRCLOCK]""
SET Y=3
DO ICLOCK(PRCLOCK,.Y)
IF 'Y
SET X=-2
QUIT
+10 DO ^DIE
if PRCLOCK]""
DO DCLOCK(PRCLOCK)
+11 SET X=$SELECT('$DATA(DA):0,$DATA(Y)=0:1,1:-1)
+12 QUIT
+13 ;
+14 ;prca = ~1 file number;file root (option);file record id
+15 ; ~2 subfile number;subfile root (option);subfile RI
+16 ; ~...
+17 ;prcb = ~1 field#;field#;...
+18 ; ~2 subfield #;subfield #;...
+19 ; ~...
+20 ;prcc = string of characters I, E. (no N) (required)
+21 ;prcd = local array name returned, it cann't be %,X,Y
+22 ; PRCA,PRCB,PRCD,PRCD,PRCE,PRCF
+23 ; @prcd(file#,record id,field #,"E")=external value
+24 ; @prcd(file#,record id,field #,"I")=internal value
PIECE(PRCA,PRCB,PRCC,PRCD) ;get piece data
+1 NEW D0,DIC,DR,DA,DIQ,PRCE,PRCF,DI
+2 SET PRCE=$PIECE(PRCA,"~")
SET DIC=+PRCE
SET DA=$PIECE(PRCE,";",3)
SET DR=$PIECE(PRCB,"~")
+3 FOR PRCF=2:1
if $PIECE(PRCA,"~",PRCF)=""
QUIT
SET PRCE=$PIECE(PRCA,"~",PRCF)
SET DA(+PRCE)=$PIECE(PRCE,";",3)
SET DR(+PRCE)=$PIECE(PRCB,"~",PRCF)
+4 SET DIQ=PRCD
SET DIQ(0)=PRCC_"N"
+5 DO EN^DIQ1
+6 QUIT
+7 ;
+8 ;prca = (sub)file node root
+9 ;prcb = node value
NODE(PRCA,PRCB) ;get node
+1 NEW PRCC
+2 SET @("PRCC=$G("_PRCA_"PRCB))")
+3 QUIT PRCC
+4 ;
+5 ;prc is piece #
NP(PRCA,PRCB,PRCC) ;get node and piece
+1 NEW PRCD
+2 SET @("PRCD=$P($G("_PRCA_"PRCB)),""^"",PRCC)")
+3 QUIT PRCD
+4 ;
+5 ;extrinsic variable for lookup screen active enteries for sd dic
+6 ;$$STATUS^PRC0B = fix value of status file 420.1999
STATUS() ;get status fix value via pointer of file 420.1999, naked '^' used for lookup screen
+1 NEW A
+2 SET A=$PIECE($GET(^(0)),U,3)
+3 QUIT $SELECT(A:$PIECE($GET(^PRCD(420.1999,A,0)),U,4),1:"A")
+4 ;
+5 ;
+6 ;
ICLOCK(A,B) ;incremental lock with time (optional)
+1 ; a = global root ending with ','
+2 ; .b = time lock seconds and value returned; false if lock fail
+3 SET A=$EXTRACT(A,1,$LENGTH(A)-1)
+4 IF $DATA(B)
LOCK +@(A_")"):B
SET B=$TEST
IF '$TEST
QUIT
+5 SET PRCLOCK(A)=$GET(PRCLOCK(A))+1
+6 IF '$DATA(B)
SET B=99999999
LOCK +@(A_")"):B
+7 QUIT
+8 ;
DCLOCK(A) ;decremental unlock
+1 ; a = global root ending with ','
+2 SET A=$EXTRACT(A,1,$LENGTH(A)-1)
+3 LOCK -@(A_")")
SET PRCLOCK(A)=$GET(PRCLOCK(A))-1
if PRCLOCK(A)<1
KILL PRCLOCK(A)
+4 QUIT
+5 ;
UNLOCK(A) ;unlock all ^PRC(A)
+1 ; a = global root ending with ','
+2 SET A=$EXTRACT(A,1,$LENGTH(A)-1)
+3 FOR
if $GET(PRCLOCK(A))<1
QUIT
LOCK -@(A_")")
SET PRCLOCK(A)=$GET(PRCLOCK(A))-1
+4 KILL PRCLOCK(A)
+5 QUIT
+6 ;
UNLKALL ;unlock all ^PRC
+1 NEW A
+2 SET A=""
FOR
SET A=$ORDER(PRCLOCK(A))
if A=""
QUIT
FOR
if $GET(PRCLOCK(A))<1
QUIT
LOCK -@(A_")")
SET PRCLOCK(A)=$GET(PRCLOCK(A))-1
+3 KILL PRCLOCK
+4 QUIT
+5 ;
