- PRSU1B1 ;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 (required);file root;file record id;field # of multiple for adding
- ; ~2 subfile number;subfile root (required);subfile RI;field # of multiple for adding
- ; ~3 ...
- ;.x = .01 internal value or array of dic and X("DR") to input for other fields
- ;.y = value returned; -1 no new entry added, ^1=ri,^2=.01 value,^3=1 for new if added
- ADD(X,Y,PRSA,DINUM) ;add new entry
- N DD,DO,DIC,%,D0,DA,DI,DIE,DLAYGO,DQ,DR,A,B,C,I
- K:$G(DINUM)="" DINUM
- 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
- S DLAYGO=PRSA,DIC(0)="FIL"
- S:$D(X(0)) DIC(0)=X(0) S:$D(X("DR")) DIC("DR")=X("DR") K X(0),X("DR")
- D FILE^DICN
- QUIT
- ;
- ;prs = ~1 file number(option);file root;file record id
- ; ~2 subfile number;subfile root;subfile RI
- ; ~...
- ;.x = value return; 1 if deleted, 0 if not, -2 if lock fail
- DELETE(X,PRSA) ;delete entry
- N %,DA,DIC,Y
- N DIK,DIA,PRSLOCK,A,B,C
- S:PRSA'?.E1"~" PRSA=PRSA_"~" S 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),DIK=$P(B,";",2),DA=$P(B,";",3),PRSLOCK=DIK_DA_","
- S X=3 D ICLOCK^PRSU1B(PRSLOCK,.X) I 'X S X=-2 QUIT
- D ^DIK,DCLOCK^PRSU1B(PRSLOCK)
- S X=1
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSU1B1 1509 printed Feb 18, 2025@23:55:15 Page 2
- PRSU1B1 ;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 (required);file root;file record id;field # of multiple for adding
- +6 ; ~2 subfile number;subfile root (required);subfile RI;field # of multiple for adding
- +7 ; ~3 ...
- +8 ;.x = .01 internal value or array of dic and X("DR") to input for other fields
- +9 ;.y = value returned; -1 no new entry added, ^1=ri,^2=.01 value,^3=1 for new if added
- ADD(X,Y,PRSA,DINUM) ;add new entry
- +1 NEW DD,DO,DIC,%,D0,DA,DI,DIE,DLAYGO,DQ,DR,A,B,C,I
- +2 if $GET(DINUM)=""
- KILL DINUM
- +3 if PRSA'?.E1"~"
- SET PRSA=PRSA_"~"
- SET A=$LENGTH(PRSA,"~")-1
- +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 DIC=$PIECE(B,";",2)
- if DIC=""&(A=1)
- SET DIC=+B
- +6 SET DLAYGO=PRSA
- SET DIC(0)="FIL"
- +7 if $DATA(X(0))
- SET DIC(0)=X(0)
- if $DATA(X("DR"))
- SET DIC("DR")=X("DR")
- KILL X(0),X("DR")
- +8 DO FILE^DICN
- +9 QUIT
- +10 ;
- +11 ;prs = ~1 file number(option);file root;file record id
- +12 ; ~2 subfile number;subfile root;subfile RI
- +13 ; ~...
- +14 ;.x = value return; 1 if deleted, 0 if not, -2 if lock fail
- DELETE(X,PRSA) ;delete entry
- +1 NEW %,DA,DIC,Y
- +2 NEW DIK,DIA,PRSLOCK,A,B,C
- +3 if PRSA'?.E1"~"
- SET PRSA=PRSA_"~"
- 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 DIK=$PIECE(B,";",2)
- SET DA=$PIECE(B,";",3)
- SET PRSLOCK=DIK_DA_","
- +6 SET X=3
- DO ICLOCK^PRSU1B(PRSLOCK,.X)
- IF 'X
- SET X=-2
- QUIT
- +7 DO ^DIK
- DO DCLOCK^PRSU1B(PRSLOCK)
- +8 SET X=1
- +9 QUIT
