PRCHCS5 ;WISC/RHD-LOG CODE SHEET STRING GENERATOR ;12/1/93 09:52
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;PRELOAD DATA INTO FILE 423, CODE SHEETS.
G:'$D(PRCHTP) DOUT K D0,DA,DIC,DIE D NEWCS^PRCFAC G:'$D(DA) DOUT
K PRCHCODS F I=0,"TRANS" S PRCHCODS(I)=^PRCF(423,DA,I)
S N=0 F I=1:1 S N=$O(PRCHTP(N)) Q:'N D ENA
S N="" F I=1:1 S N=$O(PRCHCODS(N)) Q:N="" S ^PRCF(423,DA,N)=PRCHCODS(N)
D SETR
K PRCHCODS,PRCHDA,PRCHDD,PRCHDIC,PRCHDIC1,PRCHFL,PRCHF1,PRCHF2,PRCHIN,PRCHNODE,PRCHPIEC D ^PRCFACX1 Q
ENA S PRCHDA=$P(PRCHTP(N),",",2),PRCHDD=$P(PRCHTP(N),","),PRCHDIC=$P(PRCHTP(N),",",3,999)
S:PRCHDIC="" PRCHDIC=^DIC(PRCHDD,0,"GL") S PRCHDIC=PRCHDIC_PRCHDA_","
S J=0 F I=1:1 S J=$O(PRCHTP(N,J)) Q:'J D ENB
Q
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
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)
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
S:$D(X) $P(PRCHCODS(PRCHNODE),"^",PRCHPIEC)=X Q
SETR ;PUT CODE SHEET RECORD NO.INTO FILE 410
S $P(^PRCS(410,PRCHR,"IT",PRCHLI,0),U,9)=DA Q
DOUT K PRCFA S %=0 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCS5 1488 printed Dec 13, 2024@02:06:21 Page 2
PRCHCS5 ;WISC/RHD-LOG CODE SHEET STRING GENERATOR ;12/1/93 09:52
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;PRELOAD DATA INTO FILE 423, CODE SHEETS.
+3 if '$DATA(PRCHTP)
GOTO DOUT
KILL D0,DA,DIC,DIE
DO NEWCS^PRCFAC
if '$DATA(DA)
GOTO DOUT
+4 KILL PRCHCODS
FOR I=0,"TRANS"
SET PRCHCODS(I)=^PRCF(423,DA,I)
+5 SET N=0
FOR I=1:1
SET N=$ORDER(PRCHTP(N))
if 'N
QUIT
DO ENA
+6 SET N=""
FOR I=1:1
SET N=$ORDER(PRCHCODS(N))
if N=""
QUIT
SET ^PRCF(423,DA,N)=PRCHCODS(N)
+7 DO SETR
+8 KILL PRCHCODS,PRCHDA,PRCHDD,PRCHDIC,PRCHDIC1,PRCHFL,PRCHF1,PRCHF2,PRCHIN,PRCHNODE,PRCHPIEC
DO ^PRCFACX1
QUIT
ENA SET PRCHDA=$PIECE(PRCHTP(N),",",2)
SET PRCHDD=$PIECE(PRCHTP(N),",")
SET PRCHDIC=$PIECE(PRCHTP(N),",",3,999)
+1 if PRCHDIC=""
SET PRCHDIC=^DIC(PRCHDD,0,"GL")
SET PRCHDIC=PRCHDIC_PRCHDA_","
+2 SET J=0
FOR I=1:1
SET J=$ORDER(PRCHTP(N,J))
if 'J
QUIT
DO ENB
+3 QUIT
ENB if PRCHTP(N,J)=""
QUIT
SET PRCHF1=$PIECE(PRCHTP(N,J),";")
SET PRCHF2=$PIECE(PRCHTP(N,J),";",2)
SET PRCHIN=$PIECE(PRCHTP(N,J),";",3)
IF PRCHF1'=+PRCHF1
XECUTE PRCHF1
GOTO ENC
+1 SET Y=$PIECE(^DD(PRCHDD,PRCHF1,0),"^",4)
SET PRCHNODE=$PIECE(Y,";")
SET PRCHPIEC=$PIECE(Y,";",2)
if '$DATA(PRCHDIC1(N,PRCHNODE))
SET PRCHDIC1(N,PRCHNODE)=$SELECT($DATA(@(PRCHDIC_PRCHNODE_")")):^(PRCHNODE),1:"")
SET Y=PRCHDIC1(N,PRCHNODE)
SET X=$PIECE(Y,"^",PRCHPIEC)
ENC SET Y=$PIECE(^DD(423,PRCHF2,0),"^",4,99)
SET PRCHNODE=$PIECE($PIECE(Y,"^"),";")
SET PRCHPIEC=$PIECE($PIECE(Y,"^"),";",2)
IF PRCHIN["I"!($DATA(PRCHTP("IT")))
SET PRCHITRN=$PIECE(Y,"^",2,99)
XECUTE PRCHITRN
KILL PRCHITRN
+1 if $DATA(X)
SET $PIECE(PRCHCODS(PRCHNODE),"^",PRCHPIEC)=X
QUIT
SETR ;PUT CODE SHEET RECORD NO.INTO FILE 410
+1 SET $PIECE(^PRCS(410,PRCHR,"IT",PRCHLI,0),U,9)=DA
QUIT
DOUT KILL PRCFA
SET %=0
QUIT
