PRCFACLD.m

PRCFACLD ;WISC@ALTOONA/CTB-CODE SHEET PRELOAD ;10 Sep 89/3:08 PM

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 G:'$D(F) DOUT D TT^PRCFAC G:'% DOUT D NEWCS^PRCFAC G:'$D(DA) DOUT

SE K %CS F I=0,"TRANS" S %CS(I)=^PRCF(423,PRCFA("CSDA"),I)

 S N=0 F I=1:1 S N=$O(F(N)) Q:'N  D A

 S N="" F I=1:1 S N=$O(%CS(N)) Q:'N  S ^PRCF(423,PRCFA("CSDA"),N)=%CS(N)

 I $D(DR) S DIE="^PRCF(423,",DA=PRCFA("CSDA") D ^DIE

 K %CS,%DA,%DD,%DIC,%DIC1,%FN1,%FN2,%INPT,%NODE,%PIECE Q

A S %DA=$P(F(N),",",2),%DD=$P(F(N),","),%DIC=$P(F(N),",",3)

 S:%DIC="" %DIC=^DIC(%DD,0,"GL") S %DIC=%DIC_%DA_","

 S J=0 F I=1:1 S J=$O(F(N,J)) Q:'J  D B

 Q

B Q:F(N,J)=""  S %FN1=$P(F(N,J),";"),%FN2=$P(F(N,J),";",2),%INPT=$P(F(N,J),";",3) I %FN1'=+%FN1 X %FN1 G C

 S Y=$P(^DD(%DD,%FN1,0),"^",4),%NODE=$P(Y,";"),%PIECE=$P(Y,";",2)

 S %DIC1=%DIC_%NODE_")" S Y=@(%SDIC1),X=$P(Y,"^",%PIECE)

C S Y=$P(^DD(423,%FN2,0),"^",4,99),%NODE=$P($P(Y,"^"),";"),%PIECE=$P($P(Y,"^"),";",2) I %INPT["I"!($D(F("IT"))) S %INTRANS=$P(Y,"^",2,99) X %INTRANS K %INTRANS

D S:$D(X) $P(%CS(%NODE),"^",%PIECE)=X Q

DOUT K F,PRCFA S %=0 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCFACLD   1136     printed  Apr 09, 2024@21:14:11                                                                                                                                                                                                    Page 2

PRCFACLD  ;WISC@ALTOONA/CTB-CODE SHEET PRELOAD ;10 Sep 89/3:08 PM

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2        if '$DATA(F)

               GOTO DOUT

           DO TT^PRCFAC

           if '%

               GOTO DOUT

           DO NEWCS^PRCFAC

           if '$DATA(DA)

               GOTO DOUT

SE         KILL %CS

           FOR I=0,"TRANS"

               SET %CS(I)=^PRCF(423,PRCFA("CSDA"),I)

 +1        SET N=0

           FOR I=1:1

               SET N=$ORDER(F(N))

               if 'N

                   QUIT 

               DO A

 +2        SET N=""

           FOR I=1:1

               SET N=$ORDER(%CS(N))

               if 'N

                   QUIT 

               SET ^PRCF(423,PRCFA("CSDA"),N)=%CS(N)

 +3        IF $DATA(DR)

               SET DIE="^PRCF(423,"

               SET DA=PRCFA("CSDA")

               DO ^DIE

 +4        KILL %CS,%DA,%DD,%DIC,%DIC1,%FN1,%FN2,%INPT,%NODE,%PIECE

           QUIT 

A          SET %DA=$PIECE(F(N),",",2)

           SET %DD=$PIECE(F(N),",")

           SET %DIC=$PIECE(F(N),",",3)

 +1        if %DIC=""

               SET %DIC=^DIC(%DD,0,"GL")

           SET %DIC=%DIC_%DA_","

 +2        SET J=0

           FOR I=1:1

               SET J=$ORDER(F(N,J))

               if 'J

                   QUIT 

               DO B

 +3        QUIT 

B          if F(N,J)=""

               QUIT 

           SET %FN1=$PIECE(F(N,J),";")

           SET %FN2=$PIECE(F(N,J),";",2)

           SET %INPT=$PIECE(F(N,J),";",3)

           IF %FN1'=+%FN1

               XECUTE %FN1

               GOTO C

 +1        SET Y=$PIECE(^DD(%DD,%FN1,0),"^",4)

           SET %NODE=$PIECE(Y,";")

           SET %PIECE=$PIECE(Y,";",2)

 +2        SET %DIC1=%DIC_%NODE_")"

           SET Y=@(%SDIC1)

           SET X=$PIECE(Y,"^",%PIECE)

C          SET Y=$PIECE(^DD(423,%FN2,0),"^",4,99)

           SET %NODE=$PIECE($PIECE(Y,"^"),";")

           SET %PIECE=$PIECE($PIECE(Y,"^"),";",2)

           IF %INPT["I"!($DATA(F("IT")))

               SET %INTRANS=$PIECE(Y,"^",2,99)

               XECUTE %INTRANS

               KILL %INTRANS

D          if $DATA(X)

               SET $PIECE(%CS(%NODE),"^",%PIECE)=X

           QUIT 

DOUT       KILL F,PRCFA

           SET %=0

           QUIT