| [613] | 1 | PRCHCS5 ;WISC/RHD-LOG CODE SHEET STRING GENERATOR ;12/1/93 09:52
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;PRELOAD DATA INTO FILE 423, CODE SHEETS.
|
|---|
| 5 | G:'$D(PRCHTP) DOUT K D0,DA,DIC,DIE D NEWCS^PRCFAC G:'$D(DA) DOUT
|
|---|
| 6 | K PRCHCODS F I=0,"TRANS" S PRCHCODS(I)=^PRCF(423,DA,I)
|
|---|
| 7 | S N=0 F I=1:1 S N=$O(PRCHTP(N)) Q:'N D ENA
|
|---|
| 8 | S N="" F I=1:1 S N=$O(PRCHCODS(N)) Q:N="" S ^PRCF(423,DA,N)=PRCHCODS(N)
|
|---|
| 9 | D SETR
|
|---|
| 10 | K PRCHCODS,PRCHDA,PRCHDD,PRCHDIC,PRCHDIC1,PRCHFL,PRCHF1,PRCHF2,PRCHIN,PRCHNODE,PRCHPIEC D ^PRCFACX1 Q
|
|---|
| 11 | ENA S PRCHDA=$P(PRCHTP(N),",",2),PRCHDD=$P(PRCHTP(N),","),PRCHDIC=$P(PRCHTP(N),",",3,999)
|
|---|
| 12 | S:PRCHDIC="" PRCHDIC=^DIC(PRCHDD,0,"GL") S PRCHDIC=PRCHDIC_PRCHDA_","
|
|---|
| 13 | S J=0 F I=1:1 S J=$O(PRCHTP(N,J)) Q:'J D ENB
|
|---|
| 14 | Q
|
|---|
| 15 | ENB Q:PRCHTP(N,J)="" S PRCHF1=$P(PRCHTP(N,J),";"),PRCHF2=$P(PRCHTP(N,J),";",2),PRCHIN=$P(PRCHTP(N,J),";",3) I PRCHF1'=+PRCHF1 X PRCHF1 G ENC
|
|---|
| 16 | S Y=$P(^DD(PRCHDD,PRCHF1,0),"^",4),PRCHNODE=$P(Y,";"),PRCHPIEC=$P(Y,";",2) S:'$D(PRCHDIC1(N,PRCHNODE)) PRCHDIC1(N,PRCHNODE)=$S($D(@(PRCHDIC_PRCHNODE_")")):^(PRCHNODE),1:"") S Y=PRCHDIC1(N,PRCHNODE),X=$P(Y,"^",PRCHPIEC)
|
|---|
| 17 | ENC S Y=$P(^DD(423,PRCHF2,0),"^",4,99),PRCHNODE=$P($P(Y,"^"),";"),PRCHPIEC=$P($P(Y,"^"),";",2) I PRCHIN["I"!($D(PRCHTP("IT"))) S PRCHITRN=$P(Y,"^",2,99) X PRCHITRN K PRCHITRN
|
|---|
| 18 | S:$D(X) $P(PRCHCODS(PRCHNODE),"^",PRCHPIEC)=X Q
|
|---|
| 19 | SETR ;PUT CODE SHEET RECORD NO.INTO FILE 410
|
|---|
| 20 | S $P(^PRCS(410,PRCHR,"IT",PRCHLI,0),U,9)=DA Q
|
|---|
| 21 | DOUT K PRCFA S %=0 Q
|
|---|
