PSNVCR2 ;BIR/RTR-VISTA COMPARISON REPORT CONTINUED ; 11 January 2017
;;4.0;NATIONAL DRUG FILE;**513**; 30 Oct 98;Build 53
;
;Reference to ^DIA supported by DBIA 2602
;
;
START ;Print report
N Y,DIR,DIROUT,DIRUT,DTOUT,DUOUT
START1 ;Print report without queuing
N PSNCH,PSNCRA2,PSNCRAT,PSNCROUT,PSNCRDEV,PSNCRLIN,PSNCRTOT,PSNCRPG,PSNCRBG,PSNCREN,PSNCRL2,PSNCRLC1,PSNCRLC2,PSNCRLC3,PSNCRLC4,PSNCRS7,PSNCRS8,PSNCRSUB,PSNFON,PSNCRLF,PSNCRS9,PSNCRSM9
S Y=$E(PSNVRBEG,1,7) D DD^%DT S PSNCRBG=Y
S Y=$E(PSNVREND,1,7) D DD^%DT S PSNCREN=Y
S PSNFON=$S(PSNVRTYP="P":1,1:0)
S PSNCRL2=PSNCRBG_" to "_PSNCREN I PSNVRPMI S PSNCRL2=PSNCRL2_" (Including PMI and Warning Labels)"
S (PSNCROUT,PSNCRTOT,PSNCRLF)=0,PSNCRDEV=$S($E(IOST,1,2)'="C-":"P",1:"C"),PSNCRPG=1
K PSNCRLIN S $P(PSNCRLIN,"-",78)="",PSNCRSUB=""
I PSNFON D HD
;
S PSNCH="" F S PSNCH=$O(PSNVRFIL(PSNCH)) Q:PSNCH=""!(PSNCROUT) D
.I 'PSNFON,'PSNCRLF W !
.D @$S(PSNCH=50.416:"DIN",PSNCH=50.6:"VAG",PSNCH=50.605:"VDC",PSNCH=50.606:"DFO",PSNCH=50.607:"DRU",PSNCH=50.608:"PAT",PSNCH=50.609:"PAS",PSNCH=50.64:"VAD",PSNCH=50.67:"NDC",PSNCH=50.68:"VAP",PSNCH=55.95:"DRM",1:"DRI")
.I 'PSNFON S PSNCRLF=1
I PSNCROUT G END
I PSNVRPMI D PMIP^PSNVCR1
;
END ;
I 'PSNCROUT,'PSNCRTOT W !!,"No data to print.",!
I PSNCRDEV="P" W !!,"End of Report.",!
I 'PSNCROUT,PSNCRDEV="C" W !!,"End of Report.",! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
I PSNCRDEV="C" W !
E W @IOF
K PSNVRBEG,PSNVREND,PSNVRPMI,PSNVRTYP,PSNVRAR,PSNVRFIL,PSNVRSUM
I 'PSNFON Q
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
;
;
HD ;Report Header
I $G(PSNCRDEV)="C",$G(PSNCRPG)'=1 W ! K DIR,Y S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S PSNCROUT=1 Q
W @IOF
W !,"UPDATE FILE CHANGE REPORT" W:PSNVRSUM="S" " (Summary)"
W ?68,"PAGE: "_PSNCRPG,!,PSNCRL2_PSNCRSUB,!,PSNCRLIN S PSNCRPG=PSNCRPG+1
Q
;
;
MESS ;
W !!,"Nothing queued to print.",!
Q
;
;
DIN ;print info for Drug Ingredient (#50.416) File
S PSNCRTOT=1,PSNCRAT=0,PSNCRLC1=50.416,PSNCRLC3="DRUG INGREDIENTS"
I PSNVRSUM="F" S PSNCRSUB=" (Drug Ingredient (#50.416) File cont.)"
F PSNCRA2=0:0 S PSNCRA2=$O(^PS(50.416,PSNCRA2)) Q:'PSNCRA2 I $G(^PS(50.416,PSNCRA2,0))'="" S PSNCRAT=PSNCRAT+1
I PSNFON W !!,"DRUG INGREDIENT file (#50.416) - "_PSNCRAT_" records"
I PSNFON,($Y+5)>IOSL D HD Q:PSNCROUT
D @$S(PSNVRSUM="F":"KLF",1:"KL")
I $D(PSNVRAR(PSNCRLC1)) D
.I PSNVRSUM="F" D PRT(PSNCRLC1) Q
.D SUM(PSNCRLC1)
I PSNVRSUM="F" D PFUL(PSNCRLC3,PSNCRAT),KLF Q
D PSUM(PSNCRLC3,PSNCRAT)
Q
;
;
VAG ;print info for VA Generic (#50.6) File
S PSNCRTOT=1,PSNCRAT=0,PSNCRLC1=50.6,PSNCRLC3="VA GENERIC"
I PSNVRSUM="F" S PSNCRSUB=" (VA Generic (#50.6) File cont.)"
F PSNCRA2=0:0 S PSNCRA2=$O(^PSNDF(50.6,PSNCRA2)) Q:'PSNCRA2 I $G(^PSNDF(50.6,PSNCRA2,0))'="" S PSNCRAT=PSNCRAT+1
I PSNFON W !!,"VA GENERIC file (#50.6) - "_PSNCRAT_" records"
I PSNFON,($Y+5)>IOSL D HD Q:PSNCROUT
D @$S(PSNVRSUM="F":"KLF",1:"KL")
I $D(PSNVRAR(PSNCRLC1)) D
.I PSNVRSUM="F" D PRT(PSNCRLC1) Q
.D SUM(PSNCRLC1)
I PSNVRSUM="F" D PFUL(PSNCRLC3,PSNCRAT),KLF Q
D PSUM(PSNCRLC3,PSNCRAT)
Q
;
;
VDC ;print info for VA Drug Class (#50.605) File
S PSNCRTOT=1,PSNCRAT=0,PSNCRLC1=50.605,PSNCRLC3="VA DRUG CLASS"
I PSNVRSUM="F" S PSNCRSUB=" (VA Drug Class (#50.605) File cont.)"
F PSNCRA2=0:0 S PSNCRA2=$O(^PS(50.605,PSNCRA2)) Q:'PSNCRA2 I $G(^PS(50.605,PSNCRA2,0))'="" S PSNCRAT=PSNCRAT+1
I PSNFON W !!,"VA DRUG CLASS file (#50.605) - "_PSNCRAT_" records"
I PSNFON,($Y+5)>IOSL D HD Q:PSNCROUT
D @$S(PSNVRSUM="F":"KLF",1:"KL")
I $D(PSNVRAR(PSNCRLC1)) D
.I PSNVRSUM="F" D PRT(PSNCRLC1) Q
.D SUM(PSNCRLC1)
I PSNVRSUM="F" D PFUL(PSNCRLC3,PSNCRAT),KLF Q
D PSUM(PSNCRLC3,PSNCRAT)
Q
;
;
DFO ;print info for Dosage Form (#50.606) File
S PSNCRTOT=1,PSNCRAT=0,PSNCRLC1=50.606,PSNCRLC3="DOSAGE FORM"
I PSNVRSUM="F" S PSNCRSUB=" (Dosage Form (#50.606) File cont.)"
F PSNCRA2=0:0 S PSNCRA2=$O(^PS(50.606,PSNCRA2)) Q:'PSNCRA2 I $G(^PS(50.606,PSNCRA2,0))'="" S PSNCRAT=PSNCRAT+1
I PSNFON W !!,"DOSAGE FORM file (#50.606) - "_PSNCRAT_" records"
I PSNFON,($Y+5)>IOSL D HD Q:PSNCROUT
D @$S(PSNVRSUM="F":"KLF",1:"KL")
I $D(PSNVRAR(PSNCRLC1)) D
.I PSNVRSUM="F" D PRT(PSNCRLC1) Q
.D SUM(PSNCRLC1)
I PSNVRSUM="F" D PFUL(PSNCRLC3,PSNCRAT),KLF Q
D PSUM(PSNCRLC3,PSNCRAT)
Q
;
;
DRU ;print info for Drug Units (#50.607) File
S PSNCRTOT=1,PSNCRAT=0,PSNCRLC1=50.607,PSNCRLC3="DRUG UNITS"
I PSNVRSUM="F" S PSNCRSUB=" (Drug Units (#50.607) File cont.)"
F PSNCRA2=0:0 S PSNCRA2=$O(^PS(50.607,PSNCRA2)) Q:'PSNCRA2 I $G(^PS(50.607,PSNCRA2,0))'="" S PSNCRAT=PSNCRAT+1
I PSNFON W !!,"DRUG UNITS file (#50.607) - "_PSNCRAT_" records"
I PSNFON,($Y+5)>IOSL D HD Q:PSNCROUT
D @$S(PSNVRSUM="F":"KLF",1:"KL")
I $D(PSNVRAR(PSNCRLC1)) D
.I PSNVRSUM="F" D PRT(PSNCRLC1) Q
.D SUM(PSNCRLC1)
I PSNVRSUM="F" D PFUL(PSNCRLC3,PSNCRAT),KLF Q
D PSUM(PSNCRLC3,PSNCRAT)
Q
;
;
PAT ;print info for Package Type (#50.608) File
S PSNCRTOT=1,PSNCRAT=0,PSNCRLC1=50.608,PSNCRLC3="PACKAGE TYPE"
I PSNVRSUM="F" S PSNCRSUB=" (Package Type (#50.608) File cont.)"
F PSNCRA2=0:0 S PSNCRA2=$O(^PS(50.608,PSNCRA2)) Q:'PSNCRA2 I $G(^PS(50.608,PSNCRA2,0))'="" S PSNCRAT=PSNCRAT+1
I PSNFON W !!,"PACKAGE TYPE file (#50.608) - "_PSNCRAT_" records"
I PSNFON,($Y+5)>IOSL D HD Q:PSNCROUT
D @$S(PSNVRSUM="F":"KLF",1:"KL")
I $D(PSNVRAR(PSNCRLC1)) D
.I PSNVRSUM="F" D PRT(PSNCRLC1) Q
.D SUM(PSNCRLC1)
I PSNVRSUM="F" D PFUL(PSNCRLC3,PSNCRAT),KLF Q
D PSUM(PSNCRLC3,PSNCRAT)
Q
;
;
PAS ;print info for Package Size (#50.609) File
S PSNCRTOT=1,PSNCRAT=0,PSNCRLC1=50.609,PSNCRLC3="PACKAGE SIZE"
I PSNVRSUM="F" S PSNCRSUB=" (Package Size (#50.609) File cont.)"
F PSNCRA2=0:0 S PSNCRA2=$O(^PS(50.609,PSNCRA2)) Q:'PSNCRA2 I $G(^PS(50.609,PSNCRA2,0))'="" S PSNCRAT=PSNCRAT+1
I PSNFON W !!,"PACKAGE SIZE file (#50.609) - "_PSNCRAT_" records"
I PSNFON,($Y+5)>IOSL D HD Q:PSNCROUT
D @$S(PSNVRSUM="F":"KLF",1:"KL")
I $D(PSNVRAR(PSNCRLC1)) D
.I PSNVRSUM="F" D PRT(PSNCRLC1) Q
.D SUM(PSNCRLC1)
I PSNVRSUM="F" D PFUL(PSNCRLC3,PSNCRAT),KLF Q
D PSUM(PSNCRLC3,PSNCRAT)
Q
;
;
VAD ;print info for VA Dispense Unit (#50.64) File
S PSNCRTOT=1,PSNCRAT=0,PSNCRLC1=50.64,PSNCRLC3="VA DISPENSE UNIT"
I PSNVRSUM="F" S PSNCRSUB=" (VA Dispense Unit (#50.64) File cont.)"
F PSNCRA2=0:0 S PSNCRA2=$O(^PSNDF(50.64,PSNCRA2)) Q:'PSNCRA2 I $G(^PSNDF(50.64,PSNCRA2,0))'="" S PSNCRAT=PSNCRAT+1
I PSNFON W !!,"VA DISPENSE UNIT file (#50.64) - "_PSNCRAT_" records"
I PSNFON,($Y+5)>IOSL D HD Q:PSNCROUT
D @$S(PSNVRSUM="F":"KLF",1:"KL")
I $D(PSNVRAR(PSNCRLC1)) D
.I PSNVRSUM="F" D PRT(PSNCRLC1) Q
.D SUM(PSNCRLC1)
I PSNVRSUM="F" D PFUL(PSNCRLC3,PSNCRAT),KLF Q
D PSUM(PSNCRLC3,PSNCRAT)
Q
;
;
NDC ;print info for NDC/UPN (#50.67) File
S PSNCRTOT=1,PSNCRAT=0,PSNCRLC1=50.67,PSNCRLC3="NDC/UPN"
I PSNVRSUM="F" S PSNCRSUB=" (NDC/UPN (#50.67) File cont.)"
I PSNCRDEV="C",PSNFON W !
F PSNCRA2=0:0 S PSNCRA2=$O(^PSNDF(50.67,PSNCRA2)) Q:'PSNCRA2 I $G(^PSNDF(50.67,PSNCRA2,0))'="" S PSNCRAT=PSNCRAT+1 I PSNCRDEV="C",PSNFON,PSNCRAT#20000=0 W "."
I PSNFON W !!,"NDC/UPN file (#50.67) - "_PSNCRAT_" records"
I PSNFON,($Y+5)>IOSL D HD Q:PSNCROUT
D @$S(PSNVRSUM="F":"KLF",1:"KL")
I $D(PSNVRAR(PSNCRLC1)) D
.I PSNVRSUM="F" D PRT(PSNCRLC1) Q
.D SUM(PSNCRLC1)
I PSNVRSUM="F" D PFUL(PSNCRLC3,PSNCRAT),KLF Q
D PSUM(PSNCRLC3,PSNCRAT)
Q
;
;
VAP ;print info for VA Product (#50.68) File
S PSNCRTOT=1,PSNCRAT=0,PSNCRLC1=50.68,PSNCRLC3="VA PRODUCT"
I PSNVRSUM="F" S PSNCRSUB=" (VA Product (#50.68) File cont.)"
I PSNCRDEV="C",PSNFON W !
F PSNCRA2=0:0 S PSNCRA2=$O(^PSNDF(50.68,PSNCRA2)) Q:'PSNCRA2 I $G(^PSNDF(50.68,PSNCRA2,0))'="" S PSNCRAT=PSNCRAT+1 I PSNCRDEV="C",PSNFON,PSNCRAT#5000=0 W "."
I PSNFON W !!,"VA PRODUCT file (#50.68) - "_PSNCRAT_" records"
I PSNFON,($Y+5)>IOSL D HD Q:PSNCROUT
D @$S(PSNVRSUM="F":"KLF",1:"KL")
I $D(PSNVRAR(PSNCRLC1)) D
.I PSNVRSUM="F" D PRT(PSNCRLC1) Q
.D SUM(PSNCRLC1)
I PSNVRSUM="F" D PFUL(PSNCRLC3,PSNCRAT),KLF Q
D PSUM(PSNCRLC3,PSNCRAT)
Q
;
;
DRM ;print info for Drug Manufacturer (#55.95) File
S PSNCRTOT=1,PSNCRAT=0,PSNCRLC1=55.95,PSNCRLC3="DRUG MANUFACTURER"
I PSNVRSUM="F" S PSNCRSUB=" (Drug Manufacturer (#55.95) File cont.)"
F PSNCRA2=0:0 S PSNCRA2=$O(^PS(55.95,PSNCRA2)) Q:'PSNCRA2 I $G(^PS(55.95,PSNCRA2,0))'="" S PSNCRAT=PSNCRAT+1
I PSNFON W !!,"DRUG MANUFACTURER file (#55.95) - "_PSNCRAT_" records"
I PSNFON,($Y+5)>IOSL D HD Q:PSNCROUT
D @$S(PSNVRSUM="F":"KLF",1:"KL")
I $D(PSNVRAR(PSNCRLC1)) D
.I PSNVRSUM="F" D PRT(PSNCRLC1) Q
.D SUM(PSNCRLC1)
I PSNVRSUM="F" D PFUL(PSNCRLC3,PSNCRAT),KLF Q
D PSUM(PSNCRLC3,PSNCRAT)
Q
;
;
DRI ;print info for Drug Interaction (#56) File
S PSNCRTOT=1,PSNCRAT=0,PSNCRLC1=56,PSNCRLC3="DRUG INTERACTION"
I PSNVRSUM="F" S PSNCRSUB=" (Drug Interaction (#56) File cont.)"
F PSNCRA2=0:0 S PSNCRA2=$O(^PS(56,PSNCRA2)) Q:'PSNCRA2 I $G(^PS(56,PSNCRA2,0))'="" S PSNCRAT=PSNCRAT+1
I PSNFON W !!,"DRUG INTERACTION file (#56) - "_PSNCRAT_" records"
I PSNFON,($Y+5)>IOSL D HD Q:PSNCROUT
D @$S(PSNVRSUM="F":"KLF",1:"KL")
I $D(PSNVRAR(PSNCRLC1)) D
.I PSNVRSUM="F" D PRT(PSNCRLC1) Q
.D SUM(PSNCRLC1)
I PSNVRSUM="F" D PFUL(PSNCRLC3,PSNCRAT),KLF Q
D PSUM(PSNCRLC3,PSNCRAT)
Q
;
;
PRT(PSNCRS2) ;Print Audit File changes
;TMP("PSNFFILE",$J,.01 name, IEN, Field Name, Field Number, File or Subfile #, counter)=Old Value^New Value
;PSNCRLC2(File #, IEN, File or Subfile #, Field #)=Count
N PSNCRSL1,PSNCRSL2,PSNCRSLF,PSNCRSLI,PSNCRSLN,PSNCRLAB,PSNCRNAM,PSNCROCT,PSNCRFN1,PSNCRFN2,PSNCRFN3,PSNCRFN4,PSNCRFN5,PSNCRPAS
F PSNCRSL1=PSNVRBEG:0 S PSNCRSL1=$O(^DIA(PSNCRS2,"C",PSNCRSL1)) Q:'PSNCRSL1!(PSNVREND'>PSNCRSL1) D
.F PSNCRSL2=0:0 S PSNCRSL2=$O(^DIA(PSNCRS2,"C",PSNCRSL1,PSNCRSL2)) Q:'PSNCRSL2 D
..S PSNCRSLN=$G(^DIA(PSNCRS2,PSNCRSL2,0)),PSNCRPAS=1
..S PSNCRSLI=+$P(PSNCRSLN,"^"),PSNCRSLF=$P(PSNCRSLN,"^",3) Q:'PSNCRSLI I 'PSNCRSLF S PSNCRPAS=0
..I PSNCRPAS D
...S PSNCRFN1=$P(PSNCRSLF,","),PSNCRFN2=$P(PSNCRSLF,",",2) D
....S PSNCRFN3=0 I 'PSNCRFN2,$D(PSNVRAR(PSNCRS2,PSNCRFN1)) S PSNCRFN3=PSNVRAR(PSNCRS2,PSNCRFN1) Q
....I 'PSNCRFN2 Q
....S PSNCRFN3=$G(PSNVRAR(PSNCRS2,PSNCRFN1,PSNCRFN2))
..I PSNCRPAS,'PSNCRFN3 Q
..I PSNCRPAS S PSNCRFN4=$S(PSNCRFN2:PSNCRFN3,1:PSNCRS2),PSNCRFN5=$S(PSNCRFN2:PSNCRFN2,1:PSNCRFN1)
..I PSNCRPAS,'PSNCRFN2 S PSNCRLAB=$$GET1^DID(PSNCRS2,PSNCRFN1,,"LABEL") I PSNCRLAB="" S PSNCRPAS=0
..I PSNCRPAS,PSNCRFN2 S PSNCRLAB=$$GET1^DID(PSNCRFN3,PSNCRFN2,,"LABEL") I PSNCRLAB="" S PSNCRPAS=0
..I 'PSNCRPAS S PSNCRFN4=9999999,PSNCRFN5=9999999,PSNCRLAB="UNKNOWN"
..S PSNCRNAM=$$GET1^DIQ(PSNCRS2,PSNCRSLI,.01) I PSNCRNAM="" S PSNCRNAM="ZZZZMISSING_("_PSNCRSLI_") File entry missing"
..S (PSNCRLC2(PSNCRS2,PSNCRSLI,PSNCRFN4,PSNCRFN5),PSNCROCT)=+$G(PSNCRLC2(PSNCRS2,PSNCRSLI,PSNCRFN4,PSNCRFN5))+1
..S ^TMP("PSNFFILE",$J,PSNCRNAM,PSNCRSLI,PSNCRLAB,PSNCRFN5,PSNCRFN4,PSNCROCT)=$P($G(^DIA(PSNCRS2,PSNCRSL2,2)),"^")_"^"_$P($G(^DIA(PSNCRS2,PSNCRSL2,3)),"^")
;
Q
;
;
SUM(PSNCRS6) ;Print Audit File summary changes
;PSNCRS7=Total records changed per file
;^TMP("PSNSFILE",$J,IEN)="" Used to indicate this record has already been added to the PSNCRS7 array
;PSNCRS8=Total number of Fields changed
;^TMP("PSNTFILE",$J,IEN)="" indicates already added to PSNCRS9 array, for missing PSN file entry
;PSNCRSM9=Total number of Fields changes for a missing entry
N PSNCRSL1,PSNCRSL2,PSNCRSLF,PSNCRSLI,PSNCRSLN,PSNCRM1,PSNCRM2
F PSNCRSL1=PSNVRBEG:0 S PSNCRSL1=$O(^DIA(PSNCRS6,"C",PSNCRSL1)) Q:'PSNCRSL1!(PSNVREND'>PSNCRSL1) D
.F PSNCRSL2=0:0 S PSNCRSL2=$O(^DIA(PSNCRS6,"C",PSNCRSL1,PSNCRSL2)) Q:'PSNCRSL2 D
..S PSNCRSLN=$G(^DIA(PSNCRS6,PSNCRSL2,0))
..S PSNCRSLI=+$P(PSNCRSLN,"^"),PSNCRSLF=$P(PSNCRSLN,"^",3) Q:'PSNCRSLI!('PSNCRSLF)
..S PSNCRM1=$P(PSNCRSLF,","),PSNCRM2=$P(PSNCRSLF,",",2)
..I 'PSNCRM2,'$D(PSNVRAR(PSNCRS6,PSNCRSLF)) Q
..I PSNCRM2,'$D(PSNVRAR(PSNCRS6,PSNCRM1,PSNCRM2)) Q
..I $$GET1^DIQ(PSNCRS6,PSNCRSLI,.01)="" D Q
...S PSNCRS9=PSNCRS9+1
...I '$D(^TMP("PSNTFILE",$J,PSNCRSLI)) S ^TMP("PSNTFILE",$J,PSNCRSLI)="",PSNCRSM9=PSNCRSM9+1
..S PSNCRS8=PSNCRS8+1
..I '$D(^TMP("PSNSFILE",$J,PSNCRSLI)) S ^TMP("PSNSFILE",$J,PSNCRSLI)="",PSNCRS7=PSNCRS7+1
Q
;
;
PSUM(PSNCRFDN,PSNCRFTR) ;Print summary values
I 'PSNFON D Q
.W !,PSNCRFDN_"^"_PSNCRFTR_"^"_PSNCRS7_"^"_PSNCRS8
.I PSNCRS9 W !,PSNCRFDN_" MISSING ENTRIES^"_PSNCRFTR_"^"_PSNCRSM9_"^"_PSNCRS9
I 'PSNCRS7,'PSNCRS9 D D KL Q
.W !?5,"No Change"
.I ($Y+5)>IOSL D HD
I PSNCRS7 D
.W !?5,"Records Changed: "_PSNCRS7
.I ($Y+5)>IOSL D HD I PSNCROUT D KL Q
.W !?5,"Fields/Sub-fields Changed: "_PSNCRS8
I PSNCRS9 D
.W !,PSNCRFDN_" file MISSING ENTRIES:"
.W !?5,"Records Changed: "_PSNCRSM9
.I ($Y+5)>IOSL D HD I PSNCROUT D KL Q
.W !?5,"Fields/Sub-fields Changed: "_PSNCRS9
D KL
I ($Y+5)>IOSL D HD
Q
;
;
PFUL(PSNPRHLA,PSNPRHLB) ;Print full values
;When printing, if 'File or Subfile#' changes within same field name, redisplay Field name because that means
;you have the same Field name for a top level and multiple field, and same for .01 name
N PSNPR1,PSNPR2,PSNPR3,PSNPR4,PSNPR5,PSNPR6,PSNPR7,PSNPRHLD,PSNPRHLC,PSNPRHLN,PSNPRHLM,PSNPRHLO,PSNPRHL1,PSNPRHLH,PSNPRNDC,PSNPRNDM,PSNPRMS1,PSNPRMS2
S PSNPRNDC=$S(PSNPRHLA="NDC/UPN":0,1:1) K PSNPRNDM
I 'PSNFON W !,PSNPRHLA_"^Records - "_PSNPRHLB
I '$D(^TMP("PSNFFILE",$J)) D Q
.I PSNFON W !?5,"No Change" D:($Y+5)>IOSL HD Q
.W !,PSNPRHLA_"^***No Changes***"
S PSNPRHLD="",PSNPRHL1=0
S PSNPR1="" F S PSNPR1=$O(^TMP("PSNFFILE",$J,PSNPR1)) Q:PSNPR1=""!(PSNCROUT) S PSNPRHLD="" D
.I 'PSNPRNDC S PSNPRNDM=$S($P($G(^PSNDF(50.67,PSNPR1,0)),"^",2)'="":$P($G(^PSNDF(50.67,PSNPR1,0)),"^",2),1:"Missing NDC")
.K PSNPRMS2 S PSNPRMS1=0 I $E(PSNPR1,1,11)="ZZZZMISSING" S PSNPRMS1=1,PSNPRMS2=$E(PSNPR1,12,$L(PSNPR1))
.S PSNPRHLC=0 I PSNFON W !!,$S(PSNPRNDC:PSNPR1,PSNPRMS1:PSNPRMS2,1:PSNPRNDM) I ($Y+5)>IOSL D HD I PSNCROUT Q
.I 'PSNFON S PSNPRHLH=PSNPRHLA_"^"_$S(PSNPRNDC:PSNPR1,PSNPRMS1:PSNPRMS2,1:PSNPRNDM)
.F PSNPR2=0:0 S PSNPR2=$O(^TMP("PSNFFILE",$J,PSNPR1,PSNPR2)) D:PSNPRHLD'=""&(PSNPRHL1)&(PSNPR2)&(PSNPRHLD=PSNPR1)&(PSNPRHL1'=PSNPR2) CH1 S PSNPRHLD=PSNPR1,PSNPRHL1=PSNPR2 Q:'PSNPR2!(PSNCROUT) D
..S PSNPR3="" F S PSNPR3=$O(^TMP("PSNFFILE",$J,PSNPR1,PSNPR2,PSNPR3)) Q:PSNPR3=""!(PSNCROUT) S PSNPRHLN=0,PSNPRHLM="" D
...F PSNPR4=0:0 S PSNPR4=$O(^TMP("PSNFFILE",$J,PSNPR1,PSNPR2,PSNPR3,PSNPR4)) Q:'PSNPR4!(PSNCROUT) D
....F PSNPR5=0:0 S PSNPR5=$O(^TMP("PSNFFILE",$J,PSNPR1,PSNPR2,PSNPR3,PSNPR4,PSNPR5)) D CH2 Q:'PSNPR5!(PSNCROUT) D
.....I PSNFON,($Y+5)>IOSL D HD I PSNCROUT Q
.....F PSNPR6=0:0 S PSNPR6=$O(^TMP("PSNFFILE",$J,PSNPR1,PSNPR2,PSNPR3,PSNPR4,PSNPR5,PSNPR6)) Q:'PSNPR6!(PSNCROUT) D
......S PSNPR7=$G(^TMP("PSNFFILE",$J,PSNPR1,PSNPR2,PSNPR3,PSNPR4,PSNPR5,PSNPR6))
......I 'PSNFON S PSNPRHLH=PSNPRHLH_"^"_$P(PSNPR7,"^")_"^"_$P(PSNPR7,"^",2) Q
......W !?5,"Old Value: "_$P(PSNPR7,"^") I ($Y+5)>IOSL D HD I PSNCROUT Q
......W !?5,"New Value: "_$P(PSNPR7,"^",2) I ($Y+5)>IOSL D HD I PSNCROUT Q
.....I 'PSNFON W !,PSNPRHLH S PSNPRHLH=$P(PSNPRHLH,"^")_"^"_$P(PSNPRHLH,"^",2)
Q
;
;
CH1 ;IEN change of the same name
Q:PSNCROUT
S PSNPRHLC=PSNPRHLC+1
I PSNFON W !!,PSNPR1_" (Duplicate Name #"_PSNPRHLC_")" D:($Y+5)>IOSL HD Q
S PSNPRHLH=PSNPRHLA_"^"_PSNPR1_" (Duplicate Name #"_PSNPRHLC_")"
Q
;
;
CH2 ;Subfile change of the same field name name
Q:PSNCROUT!('PSNPR5)
S:'PSNPRHLN PSNPRHLM=PSNPR4_"^"_PSNPR5
I 'PSNPRHLN,'PSNFON S PSNPRHLH=PSNPRHLH_"^"_PSNPR3_"^"_PSNPR4 S PSNPRHLN=1 Q
I 'PSNPRHLN W !!?5,PSNPR3_" ("_PSNPR4_")" S PSNPRHLN=PSNPRHLN+1 D:($Y+5)>IOSL HD Q
S PSNPRHLO=PSNPR4_"^"_PSNPR5 I PSNPRHLO'=PSNPRHLM D S PSNPRHLM=PSNPRHLO,PSNPRHLN=1 Q
.I PSNFON W !!?5,PSNPR3_" ("_PSNPR4_")"_" (Duplicate Field. SubFile #"_$P(PSNPRHLO,"^",2)_")" D:($Y+5)>IOSL HD Q
.S PSNPRHLH=PSNPRHLH_"^"_PSNPR3_" (SubFile #"_$P(PSNPRHLO,"^",2)_")^"_PSNPR4
Q
;
;
KL ;Kill TMP global
K ^TMP("PSNSFILE",$J),^TMP("PSNTFILE",$J) S (PSNCRS7,PSNCRS8,PSNCRS9,PSNCRSM9)=0
Q
;
;
KLF ;Kill TMP global
K ^TMP("PSNFFILE",$J),PSNCRLC2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNVCR2 16298 printed Sep 23, 2025@20:01:10 Page 2
PSNVCR2 ;BIR/RTR-VISTA COMPARISON REPORT CONTINUED ; 11 January 2017
+1 ;;4.0;NATIONAL DRUG FILE;**513**; 30 Oct 98;Build 53
+2 ;
+3 ;Reference to ^DIA supported by DBIA 2602
+4 ;
+5 ;
START ;Print report
+1 NEW Y,DIR,DIROUT,DIRUT,DTOUT,DUOUT
START1 ;Print report without queuing
+1 NEW PSNCH,PSNCRA2,PSNCRAT,PSNCROUT,PSNCRDEV,PSNCRLIN,PSNCRTOT,PSNCRPG,PSNCRBG,PSNCREN,PSNCRL2,PSNCRLC1,PSNCRLC2,PSNCRLC3,PSNCRLC4,PSNCRS7,PSNCRS8,PSNCRSUB,PSNFON,PSNCRLF,PSNCRS9,PSNCRSM9
+2 SET Y=$EXTRACT(PSNVRBEG,1,7)
DO DD^%DT
SET PSNCRBG=Y
+3 SET Y=$EXTRACT(PSNVREND,1,7)
DO DD^%DT
SET PSNCREN=Y
+4 SET PSNFON=$SELECT(PSNVRTYP="P":1,1:0)
+5 SET PSNCRL2=PSNCRBG_" to "_PSNCREN
IF PSNVRPMI
SET PSNCRL2=PSNCRL2_" (Including PMI and Warning Labels)"
+6 SET (PSNCROUT,PSNCRTOT,PSNCRLF)=0
SET PSNCRDEV=$SELECT($EXTRACT(IOST,1,2)'="C-":"P",1:"C")
SET PSNCRPG=1
+7 KILL PSNCRLIN
SET $PIECE(PSNCRLIN,"-",78)=""
SET PSNCRSUB=""
+8 IF PSNFON
DO HD
+9 ;
+10 SET PSNCH=""
FOR
SET PSNCH=$ORDER(PSNVRFIL(PSNCH))
if PSNCH=""!(PSNCROUT)
QUIT
Begin DoDot:1
+11 IF 'PSNFON
IF 'PSNCRLF
WRITE !
+12 DO @$SELECT(PSNCH=50.416:"DIN",PSNCH=50.6:"VAG",PSNCH=50.605:"VDC",PSNCH=50.606:"DFO",PSNCH=50.607:"DRU",PSNCH=50.608:"PAT",PSNCH=50.609:"PAS",PSNCH=50.64:"VAD",PSNCH=50.67:"NDC",PSNCH=50.68:"VAP",PSNCH=55.95:"DRM",1:"DRI")
+13 IF 'PSNFON
SET PSNCRLF=1
End DoDot:1
+14 IF PSNCROUT
GOTO END
+15 IF PSNVRPMI
DO PMIP^PSNVCR1
+16 ;
END ;
+1 IF 'PSNCROUT
IF 'PSNCRTOT
WRITE !!,"No data to print.",!
+2 IF PSNCRDEV="P"
WRITE !!,"End of Report.",!
+3 IF 'PSNCROUT
IF PSNCRDEV="C"
WRITE !!,"End of Report.",!
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+4 IF PSNCRDEV="C"
WRITE !
+5 IF '$TEST
WRITE @IOF
+6 KILL PSNVRBEG,PSNVREND,PSNVRPMI,PSNVRTYP,PSNVRAR,PSNVRFIL,PSNVRSUM
+7 IF 'PSNFON
QUIT
+8 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+9 QUIT
+10 ;
+11 ;
HD ;Report Header
+1 IF $GET(PSNCRDEV)="C"
IF $GET(PSNCRPG)'=1
WRITE !
KILL DIR,Y
SET DIR(0)="E"
SET DIR("A")="Press Return to continue, '^' to exit"
DO ^DIR
KILL DIR
IF 'Y
SET PSNCROUT=1
QUIT
+2 WRITE @IOF
+3 WRITE !,"UPDATE FILE CHANGE REPORT"
if PSNVRSUM="S"
WRITE " (Summary)"
+4 WRITE ?68,"PAGE: "_PSNCRPG,!,PSNCRL2_PSNCRSUB,!,PSNCRLIN
SET PSNCRPG=PSNCRPG+1
+5 QUIT
+6 ;
+7 ;
MESS ;
+1 WRITE !!,"Nothing queued to print.",!
+2 QUIT
+3 ;
+4 ;
DIN ;print info for Drug Ingredient (#50.416) File
+1 SET PSNCRTOT=1
SET PSNCRAT=0
SET PSNCRLC1=50.416
SET PSNCRLC3="DRUG INGREDIENTS"
+2 IF PSNVRSUM="F"
SET PSNCRSUB=" (Drug Ingredient (#50.416) File cont.)"
+3 FOR PSNCRA2=0:0
SET PSNCRA2=$ORDER(^PS(50.416,PSNCRA2))
if 'PSNCRA2
QUIT
IF $GET(^PS(50.416,PSNCRA2,0))'=""
SET PSNCRAT=PSNCRAT+1
+4 IF PSNFON
WRITE !!,"DRUG INGREDIENT file (#50.416) - "_PSNCRAT_" records"
+5 IF PSNFON
IF ($Y+5)>IOSL
DO HD
if PSNCROUT
QUIT
+6 DO @$SELECT(PSNVRSUM="F":"KLF",1:"KL")
+7 IF $DATA(PSNVRAR(PSNCRLC1))
Begin DoDot:1
+8 IF PSNVRSUM="F"
DO PRT(PSNCRLC1)
QUIT
+9 DO SUM(PSNCRLC1)
End DoDot:1
+10 IF PSNVRSUM="F"
DO PFUL(PSNCRLC3,PSNCRAT)
DO KLF
QUIT
+11 DO PSUM(PSNCRLC3,PSNCRAT)
+12 QUIT
+13 ;
+14 ;
VAG ;print info for VA Generic (#50.6) File
+1 SET PSNCRTOT=1
SET PSNCRAT=0
SET PSNCRLC1=50.6
SET PSNCRLC3="VA GENERIC"
+2 IF PSNVRSUM="F"
SET PSNCRSUB=" (VA Generic (#50.6) File cont.)"
+3 FOR PSNCRA2=0:0
SET PSNCRA2=$ORDER(^PSNDF(50.6,PSNCRA2))
if 'PSNCRA2
QUIT
IF $GET(^PSNDF(50.6,PSNCRA2,0))'=""
SET PSNCRAT=PSNCRAT+1
+4 IF PSNFON
WRITE !!,"VA GENERIC file (#50.6) - "_PSNCRAT_" records"
+5 IF PSNFON
IF ($Y+5)>IOSL
DO HD
if PSNCROUT
QUIT
+6 DO @$SELECT(PSNVRSUM="F":"KLF",1:"KL")
+7 IF $DATA(PSNVRAR(PSNCRLC1))
Begin DoDot:1
+8 IF PSNVRSUM="F"
DO PRT(PSNCRLC1)
QUIT
+9 DO SUM(PSNCRLC1)
End DoDot:1
+10 IF PSNVRSUM="F"
DO PFUL(PSNCRLC3,PSNCRAT)
DO KLF
QUIT
+11 DO PSUM(PSNCRLC3,PSNCRAT)
+12 QUIT
+13 ;
+14 ;
VDC ;print info for VA Drug Class (#50.605) File
+1 SET PSNCRTOT=1
SET PSNCRAT=0
SET PSNCRLC1=50.605
SET PSNCRLC3="VA DRUG CLASS"
+2 IF PSNVRSUM="F"
SET PSNCRSUB=" (VA Drug Class (#50.605) File cont.)"
+3 FOR PSNCRA2=0:0
SET PSNCRA2=$ORDER(^PS(50.605,PSNCRA2))
if 'PSNCRA2
QUIT
IF $GET(^PS(50.605,PSNCRA2,0))'=""
SET PSNCRAT=PSNCRAT+1
+4 IF PSNFON
WRITE !!,"VA DRUG CLASS file (#50.605) - "_PSNCRAT_" records"
+5 IF PSNFON
IF ($Y+5)>IOSL
DO HD
if PSNCROUT
QUIT
+6 DO @$SELECT(PSNVRSUM="F":"KLF",1:"KL")
+7 IF $DATA(PSNVRAR(PSNCRLC1))
Begin DoDot:1
+8 IF PSNVRSUM="F"
DO PRT(PSNCRLC1)
QUIT
+9 DO SUM(PSNCRLC1)
End DoDot:1
+10 IF PSNVRSUM="F"
DO PFUL(PSNCRLC3,PSNCRAT)
DO KLF
QUIT
+11 DO PSUM(PSNCRLC3,PSNCRAT)
+12 QUIT
+13 ;
+14 ;
DFO ;print info for Dosage Form (#50.606) File
+1 SET PSNCRTOT=1
SET PSNCRAT=0
SET PSNCRLC1=50.606
SET PSNCRLC3="DOSAGE FORM"
+2 IF PSNVRSUM="F"
SET PSNCRSUB=" (Dosage Form (#50.606) File cont.)"
+3 FOR PSNCRA2=0:0
SET PSNCRA2=$ORDER(^PS(50.606,PSNCRA2))
if 'PSNCRA2
QUIT
IF $GET(^PS(50.606,PSNCRA2,0))'=""
SET PSNCRAT=PSNCRAT+1
+4 IF PSNFON
WRITE !!,"DOSAGE FORM file (#50.606) - "_PSNCRAT_" records"
+5 IF PSNFON
IF ($Y+5)>IOSL
DO HD
if PSNCROUT
QUIT
+6 DO @$SELECT(PSNVRSUM="F":"KLF",1:"KL")
+7 IF $DATA(PSNVRAR(PSNCRLC1))
Begin DoDot:1
+8 IF PSNVRSUM="F"
DO PRT(PSNCRLC1)
QUIT
+9 DO SUM(PSNCRLC1)
End DoDot:1
+10 IF PSNVRSUM="F"
DO PFUL(PSNCRLC3,PSNCRAT)
DO KLF
QUIT
+11 DO PSUM(PSNCRLC3,PSNCRAT)
+12 QUIT
+13 ;
+14 ;
DRU ;print info for Drug Units (#50.607) File
+1 SET PSNCRTOT=1
SET PSNCRAT=0
SET PSNCRLC1=50.607
SET PSNCRLC3="DRUG UNITS"
+2 IF PSNVRSUM="F"
SET PSNCRSUB=" (Drug Units (#50.607) File cont.)"
+3 FOR PSNCRA2=0:0
SET PSNCRA2=$ORDER(^PS(50.607,PSNCRA2))
if 'PSNCRA2
QUIT
IF $GET(^PS(50.607,PSNCRA2,0))'=""
SET PSNCRAT=PSNCRAT+1
+4 IF PSNFON
WRITE !!,"DRUG UNITS file (#50.607) - "_PSNCRAT_" records"
+5 IF PSNFON
IF ($Y+5)>IOSL
DO HD
if PSNCROUT
QUIT
+6 DO @$SELECT(PSNVRSUM="F":"KLF",1:"KL")
+7 IF $DATA(PSNVRAR(PSNCRLC1))
Begin DoDot:1
+8 IF PSNVRSUM="F"
DO PRT(PSNCRLC1)
QUIT
+9 DO SUM(PSNCRLC1)
End DoDot:1
+10 IF PSNVRSUM="F"
DO PFUL(PSNCRLC3,PSNCRAT)
DO KLF
QUIT
+11 DO PSUM(PSNCRLC3,PSNCRAT)
+12 QUIT
+13 ;
+14 ;
PAT ;print info for Package Type (#50.608) File
+1 SET PSNCRTOT=1
SET PSNCRAT=0
SET PSNCRLC1=50.608
SET PSNCRLC3="PACKAGE TYPE"
+2 IF PSNVRSUM="F"
SET PSNCRSUB=" (Package Type (#50.608) File cont.)"
+3 FOR PSNCRA2=0:0
SET PSNCRA2=$ORDER(^PS(50.608,PSNCRA2))
if 'PSNCRA2
QUIT
IF $GET(^PS(50.608,PSNCRA2,0))'=""
SET PSNCRAT=PSNCRAT+1
+4 IF PSNFON
WRITE !!,"PACKAGE TYPE file (#50.608) - "_PSNCRAT_" records"
+5 IF PSNFON
IF ($Y+5)>IOSL
DO HD
if PSNCROUT
QUIT
+6 DO @$SELECT(PSNVRSUM="F":"KLF",1:"KL")
+7 IF $DATA(PSNVRAR(PSNCRLC1))
Begin DoDot:1
+8 IF PSNVRSUM="F"
DO PRT(PSNCRLC1)
QUIT
+9 DO SUM(PSNCRLC1)
End DoDot:1
+10 IF PSNVRSUM="F"
DO PFUL(PSNCRLC3,PSNCRAT)
DO KLF
QUIT
+11 DO PSUM(PSNCRLC3,PSNCRAT)
+12 QUIT
+13 ;
+14 ;
PAS ;print info for Package Size (#50.609) File
+1 SET PSNCRTOT=1
SET PSNCRAT=0
SET PSNCRLC1=50.609
SET PSNCRLC3="PACKAGE SIZE"
+2 IF PSNVRSUM="F"
SET PSNCRSUB=" (Package Size (#50.609) File cont.)"
+3 FOR PSNCRA2=0:0
SET PSNCRA2=$ORDER(^PS(50.609,PSNCRA2))
if 'PSNCRA2
QUIT
IF $GET(^PS(50.609,PSNCRA2,0))'=""
SET PSNCRAT=PSNCRAT+1
+4 IF PSNFON
WRITE !!,"PACKAGE SIZE file (#50.609) - "_PSNCRAT_" records"
+5 IF PSNFON
IF ($Y+5)>IOSL
DO HD
if PSNCROUT
QUIT
+6 DO @$SELECT(PSNVRSUM="F":"KLF",1:"KL")
+7 IF $DATA(PSNVRAR(PSNCRLC1))
Begin DoDot:1
+8 IF PSNVRSUM="F"
DO PRT(PSNCRLC1)
QUIT
+9 DO SUM(PSNCRLC1)
End DoDot:1
+10 IF PSNVRSUM="F"
DO PFUL(PSNCRLC3,PSNCRAT)
DO KLF
QUIT
+11 DO PSUM(PSNCRLC3,PSNCRAT)
+12 QUIT
+13 ;
+14 ;
VAD ;print info for VA Dispense Unit (#50.64) File
+1 SET PSNCRTOT=1
SET PSNCRAT=0
SET PSNCRLC1=50.64
SET PSNCRLC3="VA DISPENSE UNIT"
+2 IF PSNVRSUM="F"
SET PSNCRSUB=" (VA Dispense Unit (#50.64) File cont.)"
+3 FOR PSNCRA2=0:0
SET PSNCRA2=$ORDER(^PSNDF(50.64,PSNCRA2))
if 'PSNCRA2
QUIT
IF $GET(^PSNDF(50.64,PSNCRA2,0))'=""
SET PSNCRAT=PSNCRAT+1
+4 IF PSNFON
WRITE !!,"VA DISPENSE UNIT file (#50.64) - "_PSNCRAT_" records"
+5 IF PSNFON
IF ($Y+5)>IOSL
DO HD
if PSNCROUT
QUIT
+6 DO @$SELECT(PSNVRSUM="F":"KLF",1:"KL")
+7 IF $DATA(PSNVRAR(PSNCRLC1))
Begin DoDot:1
+8 IF PSNVRSUM="F"
DO PRT(PSNCRLC1)
QUIT
+9 DO SUM(PSNCRLC1)
End DoDot:1
+10 IF PSNVRSUM="F"
DO PFUL(PSNCRLC3,PSNCRAT)
DO KLF
QUIT
+11 DO PSUM(PSNCRLC3,PSNCRAT)
+12 QUIT
+13 ;
+14 ;
NDC ;print info for NDC/UPN (#50.67) File
+1 SET PSNCRTOT=1
SET PSNCRAT=0
SET PSNCRLC1=50.67
SET PSNCRLC3="NDC/UPN"
+2 IF PSNVRSUM="F"
SET PSNCRSUB=" (NDC/UPN (#50.67) File cont.)"
+3 IF PSNCRDEV="C"
IF PSNFON
WRITE !
+4 FOR PSNCRA2=0:0
SET PSNCRA2=$ORDER(^PSNDF(50.67,PSNCRA2))
if 'PSNCRA2
QUIT
IF $GET(^PSNDF(50.67,PSNCRA2,0))'=""
SET PSNCRAT=PSNCRAT+1
IF PSNCRDEV="C"
IF PSNFON
IF PSNCRAT#20000=0
WRITE "."
+5 IF PSNFON
WRITE !!,"NDC/UPN file (#50.67) - "_PSNCRAT_" records"
+6 IF PSNFON
IF ($Y+5)>IOSL
DO HD
if PSNCROUT
QUIT
+7 DO @$SELECT(PSNVRSUM="F":"KLF",1:"KL")
+8 IF $DATA(PSNVRAR(PSNCRLC1))
Begin DoDot:1
+9 IF PSNVRSUM="F"
DO PRT(PSNCRLC1)
QUIT
+10 DO SUM(PSNCRLC1)
End DoDot:1
+11 IF PSNVRSUM="F"
DO PFUL(PSNCRLC3,PSNCRAT)
DO KLF
QUIT
+12 DO PSUM(PSNCRLC3,PSNCRAT)
+13 QUIT
+14 ;
+15 ;
VAP ;print info for VA Product (#50.68) File
+1 SET PSNCRTOT=1
SET PSNCRAT=0
SET PSNCRLC1=50.68
SET PSNCRLC3="VA PRODUCT"
+2 IF PSNVRSUM="F"
SET PSNCRSUB=" (VA Product (#50.68) File cont.)"
+3 IF PSNCRDEV="C"
IF PSNFON
WRITE !
+4 FOR PSNCRA2=0:0
SET PSNCRA2=$ORDER(^PSNDF(50.68,PSNCRA2))
if 'PSNCRA2
QUIT
IF $GET(^PSNDF(50.68,PSNCRA2,0))'=""
SET PSNCRAT=PSNCRAT+1
IF PSNCRDEV="C"
IF PSNFON
IF PSNCRAT#5000=0
WRITE "."
+5 IF PSNFON
WRITE !!,"VA PRODUCT file (#50.68) - "_PSNCRAT_" records"
+6 IF PSNFON
IF ($Y+5)>IOSL
DO HD
if PSNCROUT
QUIT
+7 DO @$SELECT(PSNVRSUM="F":"KLF",1:"KL")
+8 IF $DATA(PSNVRAR(PSNCRLC1))
Begin DoDot:1
+9 IF PSNVRSUM="F"
DO PRT(PSNCRLC1)
QUIT
+10 DO SUM(PSNCRLC1)
End DoDot:1
+11 IF PSNVRSUM="F"
DO PFUL(PSNCRLC3,PSNCRAT)
DO KLF
QUIT
+12 DO PSUM(PSNCRLC3,PSNCRAT)
+13 QUIT
+14 ;
+15 ;
DRM ;print info for Drug Manufacturer (#55.95) File
+1 SET PSNCRTOT=1
SET PSNCRAT=0
SET PSNCRLC1=55.95
SET PSNCRLC3="DRUG MANUFACTURER"
+2 IF PSNVRSUM="F"
SET PSNCRSUB=" (Drug Manufacturer (#55.95) File cont.)"
+3 FOR PSNCRA2=0:0
SET PSNCRA2=$ORDER(^PS(55.95,PSNCRA2))
if 'PSNCRA2
QUIT
IF $GET(^PS(55.95,PSNCRA2,0))'=""
SET PSNCRAT=PSNCRAT+1
+4 IF PSNFON
WRITE !!,"DRUG MANUFACTURER file (#55.95) - "_PSNCRAT_" records"
+5 IF PSNFON
IF ($Y+5)>IOSL
DO HD
if PSNCROUT
QUIT
+6 DO @$SELECT(PSNVRSUM="F":"KLF",1:"KL")
+7 IF $DATA(PSNVRAR(PSNCRLC1))
Begin DoDot:1
+8 IF PSNVRSUM="F"
DO PRT(PSNCRLC1)
QUIT
+9 DO SUM(PSNCRLC1)
End DoDot:1
+10 IF PSNVRSUM="F"
DO PFUL(PSNCRLC3,PSNCRAT)
DO KLF
QUIT
+11 DO PSUM(PSNCRLC3,PSNCRAT)
+12 QUIT
+13 ;
+14 ;
DRI ;print info for Drug Interaction (#56) File
+1 SET PSNCRTOT=1
SET PSNCRAT=0
SET PSNCRLC1=56
SET PSNCRLC3="DRUG INTERACTION"
+2 IF PSNVRSUM="F"
SET PSNCRSUB=" (Drug Interaction (#56) File cont.)"
+3 FOR PSNCRA2=0:0
SET PSNCRA2=$ORDER(^PS(56,PSNCRA2))
if 'PSNCRA2
QUIT
IF $GET(^PS(56,PSNCRA2,0))'=""
SET PSNCRAT=PSNCRAT+1
+4 IF PSNFON
WRITE !!,"DRUG INTERACTION file (#56) - "_PSNCRAT_" records"
+5 IF PSNFON
IF ($Y+5)>IOSL
DO HD
if PSNCROUT
QUIT
+6 DO @$SELECT(PSNVRSUM="F":"KLF",1:"KL")
+7 IF $DATA(PSNVRAR(PSNCRLC1))
Begin DoDot:1
+8 IF PSNVRSUM="F"
DO PRT(PSNCRLC1)
QUIT
+9 DO SUM(PSNCRLC1)
End DoDot:1
+10 IF PSNVRSUM="F"
DO PFUL(PSNCRLC3,PSNCRAT)
DO KLF
QUIT
+11 DO PSUM(PSNCRLC3,PSNCRAT)
+12 QUIT
+13 ;
+14 ;
PRT(PSNCRS2) ;Print Audit File changes
+1 ;TMP("PSNFFILE",$J,.01 name, IEN, Field Name, Field Number, File or Subfile #, counter)=Old Value^New Value
+2 ;PSNCRLC2(File #, IEN, File or Subfile #, Field #)=Count
+3 NEW PSNCRSL1,PSNCRSL2,PSNCRSLF,PSNCRSLI,PSNCRSLN,PSNCRLAB,PSNCRNAM,PSNCROCT,PSNCRFN1,PSNCRFN2,PSNCRFN3,PSNCRFN4,PSNCRFN5,PSNCRPAS
+4 FOR PSNCRSL1=PSNVRBEG:0
SET PSNCRSL1=$ORDER(^DIA(PSNCRS2,"C",PSNCRSL1))
if 'PSNCRSL1!(PSNVREND'>PSNCRSL1)
QUIT
Begin DoDot:1
+5 FOR PSNCRSL2=0:0
SET PSNCRSL2=$ORDER(^DIA(PSNCRS2,"C",PSNCRSL1,PSNCRSL2))
if 'PSNCRSL2
QUIT
Begin DoDot:2
+6 SET PSNCRSLN=$GET(^DIA(PSNCRS2,PSNCRSL2,0))
SET PSNCRPAS=1
+7 SET PSNCRSLI=+$PIECE(PSNCRSLN,"^")
SET PSNCRSLF=$PIECE(PSNCRSLN,"^",3)
if 'PSNCRSLI
QUIT
IF 'PSNCRSLF
SET PSNCRPAS=0
+8 IF PSNCRPAS
Begin DoDot:3
+9 SET PSNCRFN1=$PIECE(PSNCRSLF,",")
SET PSNCRFN2=$PIECE(PSNCRSLF,",",2)
Begin DoDot:4
+10 SET PSNCRFN3=0
IF 'PSNCRFN2
IF $DATA(PSNVRAR(PSNCRS2,PSNCRFN1))
SET PSNCRFN3=PSNVRAR(PSNCRS2,PSNCRFN1)
QUIT
+11 IF 'PSNCRFN2
QUIT
+12 SET PSNCRFN3=$GET(PSNVRAR(PSNCRS2,PSNCRFN1,PSNCRFN2))
End DoDot:4
End DoDot:3
+13 IF PSNCRPAS
IF 'PSNCRFN3
QUIT
+14 IF PSNCRPAS
SET PSNCRFN4=$SELECT(PSNCRFN2:PSNCRFN3,1:PSNCRS2)
SET PSNCRFN5=$SELECT(PSNCRFN2:PSNCRFN2,1:PSNCRFN1)
+15 IF PSNCRPAS
IF 'PSNCRFN2
SET PSNCRLAB=$$GET1^DID(PSNCRS2,PSNCRFN1,,"LABEL")
IF PSNCRLAB=""
SET PSNCRPAS=0
+16 IF PSNCRPAS
IF PSNCRFN2
SET PSNCRLAB=$$GET1^DID(PSNCRFN3,PSNCRFN2,,"LABEL")
IF PSNCRLAB=""
SET PSNCRPAS=0
+17 IF 'PSNCRPAS
SET PSNCRFN4=9999999
SET PSNCRFN5=9999999
SET PSNCRLAB="UNKNOWN"
+18 SET PSNCRNAM=$$GET1^DIQ(PSNCRS2,PSNCRSLI,.01)
IF PSNCRNAM=""
SET PSNCRNAM="ZZZZMISSING_("_PSNCRSLI_") File entry missing"
+19 SET (PSNCRLC2(PSNCRS2,PSNCRSLI,PSNCRFN4,PSNCRFN5),PSNCROCT)=+$GET(PSNCRLC2(PSNCRS2,PSNCRSLI,PSNCRFN4,PSNCRFN5))+1
+20 SET ^TMP("PSNFFILE",$JOB,PSNCRNAM,PSNCRSLI,PSNCRLAB,PSNCRFN5,PSNCRFN4,PSNCROCT)=$PIECE($GET(^DIA(PSNCRS2,PSNCRSL2,2)),"^")_"^"_$PIECE($GET(^DIA(PSNCRS2,PSNCRSL2,3)),"^")
End DoDot:2
End DoDot:1
+21 ;
+22 QUIT
+23 ;
+24 ;
SUM(PSNCRS6) ;Print Audit File summary changes
+1 ;PSNCRS7=Total records changed per file
+2 ;^TMP("PSNSFILE",$J,IEN)="" Used to indicate this record has already been added to the PSNCRS7 array
+3 ;PSNCRS8=Total number of Fields changed
+4 ;^TMP("PSNTFILE",$J,IEN)="" indicates already added to PSNCRS9 array, for missing PSN file entry
+5 ;PSNCRSM9=Total number of Fields changes for a missing entry
+6 NEW PSNCRSL1,PSNCRSL2,PSNCRSLF,PSNCRSLI,PSNCRSLN,PSNCRM1,PSNCRM2
+7 FOR PSNCRSL1=PSNVRBEG:0
SET PSNCRSL1=$ORDER(^DIA(PSNCRS6,"C",PSNCRSL1))
if 'PSNCRSL1!(PSNVREND'>PSNCRSL1)
QUIT
Begin DoDot:1
+8 FOR PSNCRSL2=0:0
SET PSNCRSL2=$ORDER(^DIA(PSNCRS6,"C",PSNCRSL1,PSNCRSL2))
if 'PSNCRSL2
QUIT
Begin DoDot:2
+9 SET PSNCRSLN=$GET(^DIA(PSNCRS6,PSNCRSL2,0))
+10 SET PSNCRSLI=+$PIECE(PSNCRSLN,"^")
SET PSNCRSLF=$PIECE(PSNCRSLN,"^",3)
if 'PSNCRSLI!('PSNCRSLF)
QUIT
+11 SET PSNCRM1=$PIECE(PSNCRSLF,",")
SET PSNCRM2=$PIECE(PSNCRSLF,",",2)
+12 IF 'PSNCRM2
IF '$DATA(PSNVRAR(PSNCRS6,PSNCRSLF))
QUIT
+13 IF PSNCRM2
IF '$DATA(PSNVRAR(PSNCRS6,PSNCRM1,PSNCRM2))
QUIT
+14 IF $$GET1^DIQ(PSNCRS6,PSNCRSLI,.01)=""
Begin DoDot:3
+15 SET PSNCRS9=PSNCRS9+1
+16 IF '$DATA(^TMP("PSNTFILE",$JOB,PSNCRSLI))
SET ^TMP("PSNTFILE",$JOB,PSNCRSLI)=""
SET PSNCRSM9=PSNCRSM9+1
End DoDot:3
QUIT
+17 SET PSNCRS8=PSNCRS8+1
+18 IF '$DATA(^TMP("PSNSFILE",$JOB,PSNCRSLI))
SET ^TMP("PSNSFILE",$JOB,PSNCRSLI)=""
SET PSNCRS7=PSNCRS7+1
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
+21 ;
PSUM(PSNCRFDN,PSNCRFTR) ;Print summary values
+1 IF 'PSNFON
Begin DoDot:1
+2 WRITE !,PSNCRFDN_"^"_PSNCRFTR_"^"_PSNCRS7_"^"_PSNCRS8
+3 IF PSNCRS9
WRITE !,PSNCRFDN_" MISSING ENTRIES^"_PSNCRFTR_"^"_PSNCRSM9_"^"_PSNCRS9
End DoDot:1
QUIT
+4 IF 'PSNCRS7
IF 'PSNCRS9
Begin DoDot:1
+5 WRITE !?5,"No Change"
+6 IF ($Y+5)>IOSL
DO HD
End DoDot:1
DO KL
QUIT
+7 IF PSNCRS7
Begin DoDot:1
+8 WRITE !?5,"Records Changed: "_PSNCRS7
+9 IF ($Y+5)>IOSL
DO HD
IF PSNCROUT
DO KL
QUIT
+10 WRITE !?5,"Fields/Sub-fields Changed: "_PSNCRS8
End DoDot:1
+11 IF PSNCRS9
Begin DoDot:1
+12 WRITE !,PSNCRFDN_" file MISSING ENTRIES:"
+13 WRITE !?5,"Records Changed: "_PSNCRSM9
+14 IF ($Y+5)>IOSL
DO HD
IF PSNCROUT
DO KL
QUIT
+15 WRITE !?5,"Fields/Sub-fields Changed: "_PSNCRS9
End DoDot:1
+16 DO KL
+17 IF ($Y+5)>IOSL
DO HD
+18 QUIT
+19 ;
+20 ;
PFUL(PSNPRHLA,PSNPRHLB) ;Print full values
+1 ;When printing, if 'File or Subfile#' changes within same field name, redisplay Field name because that means
+2 ;you have the same Field name for a top level and multiple field, and same for .01 name
+3 NEW PSNPR1,PSNPR2,PSNPR3,PSNPR4,PSNPR5,PSNPR6,PSNPR7,PSNPRHLD,PSNPRHLC,PSNPRHLN,PSNPRHLM,PSNPRHLO,PSNPRHL1,PSNPRHLH,PSNPRNDC,PSNPRNDM,PSNPRMS1,PSNPRMS2
+4 SET PSNPRNDC=$SELECT(PSNPRHLA="NDC/UPN":0,1:1)
KILL PSNPRNDM
+5 IF 'PSNFON
WRITE !,PSNPRHLA_"^Records - "_PSNPRHLB
+6 IF '$DATA(^TMP("PSNFFILE",$JOB))
Begin DoDot:1
+7 IF PSNFON
WRITE !?5,"No Change"
if ($Y+5)>IOSL
DO HD
QUIT
+8 WRITE !,PSNPRHLA_"^***No Changes***"
End DoDot:1
QUIT
+9 SET PSNPRHLD=""
SET PSNPRHL1=0
+10 SET PSNPR1=""
FOR
SET PSNPR1=$ORDER(^TMP("PSNFFILE",$JOB,PSNPR1))
if PSNPR1=""!(PSNCROUT)
QUIT
SET PSNPRHLD=""
Begin DoDot:1
+11 IF 'PSNPRNDC
SET PSNPRNDM=$SELECT($PIECE($GET(^PSNDF(50.67,PSNPR1,0)),"^",2)'="":$PIECE($GET(^PSNDF(50.67,PSNPR1,0)),"^",2),1:"Missing NDC")
+12 KILL PSNPRMS2
SET PSNPRMS1=0
IF $EXTRACT(PSNPR1,1,11)="ZZZZMISSING"
SET PSNPRMS1=1
SET PSNPRMS2=$EXTRACT(PSNPR1,12,$LENGTH(PSNPR1))
+13 SET PSNPRHLC=0
IF PSNFON
WRITE !!,$SELECT(PSNPRNDC:PSNPR1,PSNPRMS1:PSNPRMS2,1:PSNPRNDM)
IF ($Y+5)>IOSL
DO HD
IF PSNCROUT
QUIT
+14 IF 'PSNFON
SET PSNPRHLH=PSNPRHLA_"^"_$SELECT(PSNPRNDC:PSNPR1,PSNPRMS1:PSNPRMS2,1:PSNPRNDM)
+15 FOR PSNPR2=0:0
SET PSNPR2=$ORDER(^TMP("PSNFFILE",$JOB,PSNPR1,PSNPR2))
if PSNPRHLD'=""&(PSNPRHL1)&(PSNPR2)&(PSNPRHLD=PSNPR1)&(PSNPRHL1'=PSNPR2)
DO CH1
SET PSNPRHLD=PSNPR1
SET PSNPRHL1=PSNPR2
if 'PSNPR2!(PSNCROUT)
QUIT
Begin DoDot:2
+16 SET PSNPR3=""
FOR
SET PSNPR3=$ORDER(^TMP("PSNFFILE",$JOB,PSNPR1,PSNPR2,PSNPR3))
if PSNPR3=""!(PSNCROUT)
QUIT
SET PSNPRHLN=0
SET PSNPRHLM=""
Begin DoDot:3
+17 FOR PSNPR4=0:0
SET PSNPR4=$ORDER(^TMP("PSNFFILE",$JOB,PSNPR1,PSNPR2,PSNPR3,PSNPR4))
if 'PSNPR4!(PSNCROUT)
QUIT
Begin DoDot:4
+18 FOR PSNPR5=0:0
SET PSNPR5=$ORDER(^TMP("PSNFFILE",$JOB,PSNPR1,PSNPR2,PSNPR3,PSNPR4,PSNPR5))
DO CH2
if 'PSNPR5!(PSNCROUT)
QUIT
Begin DoDot:5
+19 IF PSNFON
IF ($Y+5)>IOSL
DO HD
IF PSNCROUT
QUIT
+20 FOR PSNPR6=0:0
SET PSNPR6=$ORDER(^TMP("PSNFFILE",$JOB,PSNPR1,PSNPR2,PSNPR3,PSNPR4,PSNPR5,PSNPR6))
if 'PSNPR6!(PSNCROUT)
QUIT
Begin DoDot:6
+21 SET PSNPR7=$GET(^TMP("PSNFFILE",$JOB,PSNPR1,PSNPR2,PSNPR3,PSNPR4,PSNPR5,PSNPR6))
+22 IF 'PSNFON
SET PSNPRHLH=PSNPRHLH_"^"_$PIECE(PSNPR7,"^")_"^"_$PIECE(PSNPR7,"^",2)
QUIT
+23 WRITE !?5,"Old Value: "_$PIECE(PSNPR7,"^")
IF ($Y+5)>IOSL
DO HD
IF PSNCROUT
QUIT
+24 WRITE !?5,"New Value: "_$PIECE(PSNPR7,"^",2)
IF ($Y+5)>IOSL
DO HD
IF PSNCROUT
QUIT
End DoDot:6
+25 IF 'PSNFON
WRITE !,PSNPRHLH
SET PSNPRHLH=$PIECE(PSNPRHLH,"^")_"^"_$PIECE(PSNPRHLH,"^",2)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
+28 ;
CH1 ;IEN change of the same name
+1 if PSNCROUT
QUIT
+2 SET PSNPRHLC=PSNPRHLC+1
+3 IF PSNFON
WRITE !!,PSNPR1_" (Duplicate Name #"_PSNPRHLC_")"
if ($Y+5)>IOSL
DO HD
QUIT
+4 SET PSNPRHLH=PSNPRHLA_"^"_PSNPR1_" (Duplicate Name #"_PSNPRHLC_")"
+5 QUIT
+6 ;
+7 ;
CH2 ;Subfile change of the same field name name
+1 if PSNCROUT!('PSNPR5)
QUIT
+2 if 'PSNPRHLN
SET PSNPRHLM=PSNPR4_"^"_PSNPR5
+3 IF 'PSNPRHLN
IF 'PSNFON
SET PSNPRHLH=PSNPRHLH_"^"_PSNPR3_"^"_PSNPR4
SET PSNPRHLN=1
QUIT
+4 IF 'PSNPRHLN
WRITE !!?5,PSNPR3_" ("_PSNPR4_")"
SET PSNPRHLN=PSNPRHLN+1
if ($Y+5)>IOSL
DO HD
QUIT
+5 SET PSNPRHLO=PSNPR4_"^"_PSNPR5
IF PSNPRHLO'=PSNPRHLM
Begin DoDot:1
+6 IF PSNFON
WRITE !!?5,PSNPR3_" ("_PSNPR4_")"_" (Duplicate Field. SubFile #"_$PIECE(PSNPRHLO,"^",2)_")"
if ($Y+5)>IOSL
DO HD
QUIT
+7 SET PSNPRHLH=PSNPRHLH_"^"_PSNPR3_" (SubFile #"_$PIECE(PSNPRHLO,"^",2)_")^"_PSNPR4
End DoDot:1
SET PSNPRHLM=PSNPRHLO
SET PSNPRHLN=1
QUIT
+8 QUIT
+9 ;
+10 ;
KL ;Kill TMP global
+1 KILL ^TMP("PSNSFILE",$JOB),^TMP("PSNTFILE",$JOB)
SET (PSNCRS7,PSNCRS8,PSNCRS9,PSNCRSM9)=0
+2 QUIT
+3 ;
+4 ;
KLF ;Kill TMP global
+1 KILL ^TMP("PSNFFILE",$JOB),PSNCRLC2
+2 QUIT
