PSN4P365 ;ALB/HW-Post Install Routine removes incorrect data ; 02/18/14 13:09
;;4.0;NATIONAL DRUG FILE;**365**;30 Oct 98;Build 9
Q ;Must be called at entry point
EN ;Find and delete incorrect entry and related cross-references
N PSNDIEN,PSNIIEN,PSNFILE,PSNFDA,PSNRN,PSNCTR,PSNERR,Y
S PSNDIEN=""
F S PSNDIEN=$O(^PS(50.416,"B","VARENICLINE",PSNDIEN)) Q:PSNDIEN="" D
.I $D(^PS(50.416,PSNDIEN,1,0))=10!($D(^PS(50.416,PSNDIEN,1,0))=0) D FZNODE
.S PSNIIEN=""
. F S PSNIIEN=$O(^PS(50.416,PSNDIEN,1,"B","184A20598",PSNIIEN)) Q:PSNIIEN="" D
..S PSNFILE=50.4161
..I $$GET1^DIQ(PSNFILE,PSNIIEN_","_PSNDIEN_",",.01)]"" D
...S PSNFDA(PSNFILE,PSNIIEN_","_PSNDIEN_",",.01)="@"
...D FILE^DIE("","PSNFDA","PSNERR")
...K PSNFDA Q
..Q
I $D(PSNERR) W !,"CHECK ERROR LOG FOR ERRORS"
Q
FZNODE ;If the zero multiple node is missing add it first
S PSNRN="",PSNCTR=""
F S PSNRN=$O(^PS(50.416,PSNDIEN,1,PSNRN)) Q:PSNRN'>0 D
.S PSNCTR=PSNCTR+1
S ^PS(50.416,PSNDIEN,1,0)="^50.4161A^"_PSNCTR_"^"_PSNCTR_""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSN4P365 1031 printed Sep 23, 2025@19:58:15 Page 2
PSN4P365 ;ALB/HW-Post Install Routine removes incorrect data ; 02/18/14 13:09
+1 ;;4.0;NATIONAL DRUG FILE;**365**;30 Oct 98;Build 9
+2 ;Must be called at entry point
QUIT
EN ;Find and delete incorrect entry and related cross-references
+1 NEW PSNDIEN,PSNIIEN,PSNFILE,PSNFDA,PSNRN,PSNCTR,PSNERR,Y
+2 SET PSNDIEN=""
+3 FOR
SET PSNDIEN=$ORDER(^PS(50.416,"B","VARENICLINE",PSNDIEN))
if PSNDIEN=""
QUIT
Begin DoDot:1
+4 IF $DATA(^PS(50.416,PSNDIEN,1,0))=10!($DATA(^PS(50.416,PSNDIEN,1,0))=0)
DO FZNODE
+5 SET PSNIIEN=""
+6 FOR
SET PSNIIEN=$ORDER(^PS(50.416,PSNDIEN,1,"B","184A20598",PSNIIEN))
if PSNIIEN=""
QUIT
Begin DoDot:2
+7 SET PSNFILE=50.4161
+8 IF $$GET1^DIQ(PSNFILE,PSNIIEN_","_PSNDIEN_",",.01)]""
Begin DoDot:3
+9 SET PSNFDA(PSNFILE,PSNIIEN_","_PSNDIEN_",",.01)="@"
+10 DO FILE^DIE("","PSNFDA","PSNERR")
+11 KILL PSNFDA
QUIT
End DoDot:3
+12 QUIT
End DoDot:2
End DoDot:1
+13 IF $DATA(PSNERR)
WRITE !,"CHECK ERROR LOG FOR ERRORS"
+14 QUIT
FZNODE ;If the zero multiple node is missing add it first
+1 SET PSNRN=""
SET PSNCTR=""
+2 FOR
SET PSNRN=$ORDER(^PS(50.416,PSNDIEN,1,PSNRN))
if PSNRN'>0
QUIT
Begin DoDot:1
+3 SET PSNCTR=PSNCTR+1
End DoDot:1
+4 SET ^PS(50.416,PSNDIEN,1,0)="^50.4161A^"_PSNCTR_"^"_PSNCTR_""
+5 QUIT
