- 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 ---[H[J[2J[HPRCFACLD 1136 printed Apr 23, 2025@18:16:31 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
