PRC0B1.m

PRC0B1 ;WISC/PLT-UTILITY ; 06/30/94  12:40 PM

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;subfile RI;field # of multiple for adding

 ;     ~3 ...

 ;.x = .01 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,PRCA,DINUM) ;add new entry

 N DD,DO,DIC,%,D0,DA,DI,DIE,DLAYGO,DQ,DR,A,B,C,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

 S DLAYGO=PRCA,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

 ;

 ;prca = ~1 file number(option);file root;file record id

 ;       ~2 subfile number(option);subfile root;subfile RI

 ;       ~...

 ;.x = value return; 1 if deleted, 0 if not, -2 if lock fail

DELETE(X,PRCA) ;delete entry

 N %,DA,DIC,Y

 N DIK,DIA,PRCLOCK,A,B,C

 S:PRCA'?.E1"~" PRCA=PRCA_"~" S 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),DIK=$P(B,";",2),DA=$P(B,";",3),PRCLOCK=DIK_DA_","

 S X=3 D ICLOCK^PRC0B(PRCLOCK,.X) I 'X S X=-2 QUIT

 D ^DIK,DCLOCK^PRC0B(PRCLOCK)

 S X=1

 QUIT

 ;

 ;A=global root (including cross reference) ending with ','

 ;B=start value

FIRST(A,B) ;$O-first node after B-value

 N C

 S @("C=$O("_A_"B))")

 QUIT C

 ;

DICP(A,B) ;EF value=2nd piece of 0-node of the multiple field's dd entry

 QUIT $S(A&B:$P($G(^DD(A,B,0)),"^",2),1:"")

 ;

 ;

DICGL(A) ;EF value=global root ending with ',' for file # A.

 QUIT $G(^DIC(A,0,"GL"))

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRC0B1   1884     printed  Apr 09, 2024@21:11:45                                                                                                                                                                                                      Page 2

PRC0B1    ;WISC/PLT-UTILITY ; 06/30/94  12:40 PM

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;subfile RI;field # of multiple for adding

 +6       ;     ~3 ...

 +7       ;.x = .01 value or array of dic and X("DR") to input for other fields

 +8       ;.y = value returned; -1 no new entry added, ^1=ri,^2=.01 value,^3=1 for new if added

ADD(X,Y,PRCA,DINUM) ;add new entry

 +1        NEW DD,DO,DIC,%,D0,DA,DI,DIE,DLAYGO,DQ,DR,A,B,C,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        SET DLAYGO=PRCA

           SET DIC(0)="FIL"

 +6        if $DATA(X(0))

               SET DIC(0)=X(0)

           if $DATA(X("DR"))

               SET DIC("DR")=X("DR")

           KILL X(0),X("DR")

 +7        DO FILE^DICN

 +8        QUIT 

 +9       ;

 +10      ;prca = ~1 file number(option);file root;file record id

 +11      ;       ~2 subfile number(option);subfile root;subfile RI

 +12      ;       ~...

 +13      ;.x = value return; 1 if deleted, 0 if not, -2 if lock fail

DELETE(X,PRCA) ;delete entry

 +1        NEW %,DA,DIC,Y

 +2        NEW DIK,DIA,PRCLOCK,A,B,C

 +3        if PRCA'?.E1"~"

               SET PRCA=PRCA_"~"

           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 DIK=$PIECE(B,";",2)

           SET DA=$PIECE(B,";",3)

           SET PRCLOCK=DIK_DA_","

 +6        SET X=3

           DO ICLOCK^PRC0B(PRCLOCK,.X)

           IF 'X

               SET X=-2

               QUIT 

 +7        DO ^DIK

           DO DCLOCK^PRC0B(PRCLOCK)

 +8        SET X=1

 +9        QUIT 

 +10      ;

 +11      ;A=global root (including cross reference) ending with ','

 +12      ;B=start value

FIRST(A,B) ;$O-first node after B-value

 +1        NEW C

 +2        SET @("C=$O("_A_"B))")

 +3        QUIT C

 +4       ;

DICP(A,B) ;EF value=2nd piece of 0-node of the multiple field's dd entry

 +1        QUIT $SELECT(A&B:$PIECE($GET(^DD(A,B,0)),"^",2),1:"")

 +2       ;

 +3       ;

DICGL(A)  ;EF value=global root ending with ',' for file # A.

 +1        QUIT $GET(^DIC(A,0,"GL"))

 +2       ;