PSN390P ;BIR/WRT-Unwind Transport Global and set pieces in VA PRODUCT file ; 04 Mar 2014 5:21 PM
;;4.0;NATIONAL DRUG FILE;**390**; 30 Oct 98;Build 80
;
BUILD ;GET PMIS INFO FROM TRANSPORT GLOBAL AND LOAD
I '$D(XPDGREF) Q
N DA,I,J,K,LINE,PSN,ROOT,X
F PSN=50.621:.001:50.627 K ^PS(PSN)
S ROOT=$NA(@XPDGREF@("DATA")),J=0
K ^TMP($J)
F S J=$O(@ROOT@(J)) Q:'J S LINE=^(J),K=$L(LINE,"|")-1 F I=1:1:K S X=$P(LINE,"|",I),^TMP($J,$P(X,"^"))=$P(X,"^",2,4)
S DA=0 F S DA=$O(^PSNDF(50.68,DA)) Q:'DA S X=$P($G(^(DA,1)),"^",1,4) S:$D(^TMP($J,DA)) X=X_"^"_^(DA) S ^PSNDF(50.68,DA,1)=X
K ^TMP($J)
F PSN=50.621:.001:50.627 M ^PS(PSN)=@XPDGREF@(PSN)
K DA,I,J,K,LINE,PSN,ROOT,X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSN390P 693 printed Dec 13, 2024@02:20:40 Page 2
PSN390P ;BIR/WRT-Unwind Transport Global and set pieces in VA PRODUCT file ; 04 Mar 2014 5:21 PM
+1 ;;4.0;NATIONAL DRUG FILE;**390**; 30 Oct 98;Build 80
+2 ;
BUILD ;GET PMIS INFO FROM TRANSPORT GLOBAL AND LOAD
+1 IF '$DATA(XPDGREF)
QUIT
+2 NEW DA,I,J,K,LINE,PSN,ROOT,X
+3 FOR PSN=50.621:.001:50.627
KILL ^PS(PSN)
+4 SET ROOT=$NAME(@XPDGREF@("DATA"))
SET J=0
+5 KILL ^TMP($JOB)
+6 FOR
SET J=$ORDER(@ROOT@(J))
if 'J
QUIT
SET LINE=^(J)
SET K=$LENGTH(LINE,"|")-1
FOR I=1:1:K
SET X=$PIECE(LINE,"|",I)
SET ^TMP($JOB,$PIECE(X,"^"))=$PIECE(X,"^",2,4)
+7 SET DA=0
FOR
SET DA=$ORDER(^PSNDF(50.68,DA))
if 'DA
QUIT
SET X=$PIECE($GET(^(DA,1)),"^",1,4)
if $DATA(^TMP($JOB,DA))
SET X=X_"^"_^(DA)
SET ^PSNDF(50.68,DA,1)=X
+8 KILL ^TMP($JOB)
+9 FOR PSN=50.621:.001:50.627
MERGE ^PS(PSN)=@XPDGREF@(PSN)
+10 KILL DA,I,J,K,LINE,PSN,ROOT,X
+11 QUIT
