PSNMRG ;BIR/CCH&WRT-merges NDF fields into PSDRUG ; 04/18/01 14:56
;;4.0;NATIONAL DRUG FILE;**2,22,27,51,55,59,60,65,84,569**; 30 Oct 98;Build 3
;
;Reference to ^PS(50.3 supported by DBIA #2612
;Reference to ^PSDRUG supported by DBIA #2352,#221
;Reference to EN2^PSSUTIL supported by DBIA #3107
;Reference to ^PS(59.7 supported by DBIA #2613
;Reference to ^PS(59 supported by DBIA #1976
;IA 3621 - DRG^PSSHUIDG(DA)
;IA 4394 - DRG^PSSDGUPD(DA) HL7 V.2.4 dispensing machines
;
W !,"This option will merge NDF fields into your local drug file. This will also",!,"produce an Error Report for entries in the translation file which are not",!,"in the local file if they should exist."
W " These exceptions will not be merged.",!
W !,"You may queue this report if you wish.",!
DVC K %ZIS,POP,IOP S %ZIS="QM",%ZIS("B")="",%ZIS("A")="Select Printer: " D ^%ZIS G:POP DONE W:$E(IOST)'="P" !!,"This report must be run on a printer.",!! G:$E(IOST)'="P" DVC I POP K IOP,POP,IO("Q") Q
QUE I $D(IO("Q")) K IO("Q") S ZTRTN="ENQ^PSNMRG",ZTDESC="Merge Error Report" D ^%ZTLOAD K ZTSK D ^%ZISC Q
ENQ U IO S PSNPGCT=0,PSNPGLNG=IOSL-6 D TITLE,LOOP
DONE W @IOF S:$D(ZTQUEUED) ZTREQ="@" K PSNPGLNG,PSNPGCT,Y,MJT,POP,VADC,PRIM,FLAG,IOP,IO("Q") D ^%ZISC
Q
TITLE I $D(IOF),IOF]"" W @IOF S PSNPGCT=PSNPGCT+1
W !,?32,"MERGE ERROR REPORT",!
S Y=DT X ^DD("DD") W !,"Date Printed: ",Y,?73,"Page: ",PSNPGCT,!
W !!,"INTERNAL FILE NUMBER",?30,"VA PRODUCT NAME",!
F MJT=1:1:80 W "-"
Q
LOOP D:$D(XRTL) T0^%ZOSV K ^TMP($J,"PSN") F PSNB=0:0 S PSNB=$O(^PSNTRAN(PSNB)) Q:'PSNB D SET
S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; STOP
I '$D(^TMP($J,"PSN")) W !!,?30,"No Errors Found During Merge",!!!
I $D(^TMP($J,"PSN")) F PSNB=0:0 S PSNB=$O(^TMP($J,"PSN",PSNB)) Q:'PSNB D:$Y+5>IOSL TITLE W !,?8,PSNB,?30,FRMNAM,!,"***** This entry no longer exists in your local drug file. ***** ",!," This entry will not be merged. ",! K ^PSNTRAN(PSNB,0)
I $D(^TMP("PSNDP",$J)) S DISPNM="" F S DISPNM=$O(^TMP("PSNDP",$J,DISPNM)) Q:DISPNM="" D:$Y+5>IOSL TITLE W !,?5,DISPNM,?51,"needs to be rematched to Orderable Item."
I $D(^TMP("PSNAD",$J)) S ADNM="" F S ADNM=$O(^TMP("PSNAD",$J,ADNM)) Q:ADNM="" D:$Y+5>IOSL TITLE W !,"Additive ",?12,ADNM,?51,"needs to be rematched to Orderable Item."
I $D(^TMP("PSNSL",$J)) S SLNM="" F S SLNM=$O(^TMP("PSNSL",$J,SLNM)) Q:SLNM="" D:$Y+5>IOSL TITLE W !,"Solution ",?12,SLNM,?51,"needs to be rematched to Orderable Item."
KILLIT K ANS,CLDA,PSNNODE,PSNB,PSNIO,ZTRTN,FRMNAM,^TMP("PSNAD",$J),^TMP("PSNDP",$J),^TMP("PSNSL",$J),SLNM,ADNM,DISPNM Q
Q
SET I $D(PSNFL) Q:PSNFL
Q:'$D(^PSNTRAN(PSNB,0)) Q:$P(^PSNTRAN(PSNB,0),"^",9)'="Y" I '$D(^PSDRUG(PSNB)) S FRMNAM=$P(^PSNDF(50.68,$P(^PSNTRAN(PSNB,0),"^",2),0),"^"),^TMP($J,"PSN",PSNB,FRMNAM)="" Q
I $D(^PSDRUG("VAC")) F VADC=0:0 S VADC=$O(^PSDRUG("VAC",VADC)) Q:'VADC I $D(^PSDRUG("VAC",VADC,PSNB)) K ^PSDRUG("VAC",VADC,PSNB)
S PSNNODE=^PSNTRAN(PSNB,0)
S ^PSDRUG(PSNB,"ND")=$P(PSNNODE,"^")_"^"_$P(^PSNDF(50.68,$P(PSNNODE,"^",2),0),"^")_"^"_$P(PSNNODE,"^",2)_"^"_$P(PSNNODE,"^",5)_"^"_$P(PSNNODE,"^",7)_"^"_$P(PSNNODE,"^",3)
S:$P(PSNNODE,"^",3)'="" ^PSDRUG("VAC",$P(PSNNODE,"^",3),PSNB)=""
S PSNEX=$E($P(^PSDRUG(PSNB,"ND"),"^",2),1,30) S:PSNEX'="" ^PSDRUG("VAPN",PSNEX,PSNB)="" K PSNEX
I $P(PSNNODE,"^",1) S ^PSDRUG("AND",$P(PSNNODE,"^",1),PSNB)=""
I $P(PSNNODE,"^",2) S ^PSDRUG("APR",$P(PSNNODE,"^",2),PSNB)=""
I $P($G(^PSDRUG(PSNB,2)),"^",6),$P(PSNNODE,"^",1),$P(PSNNODE,"^",2) S ^PSDRUG("APN",$P($G(^PSDRUG(PSNB,2)),"^",6),$P(PSNNODE,"^",1)_"A"_$P(PSNNODE,"^",2),PSNB)=""
S MMM=$P(^PSDRUG(PSNB,"ND"),"^",1),NNN=$P(^PSDRUG(PSNB,"ND"),"^",3),DA=MMM,K=NNN,X=$$PROD2^PSNAPIS(DA,K) I X]"",$P(X,"^")]"" S $P(^PSDRUG(PSNB,"ND"),"^",10)=$P(X,"^",2),^PSDRUG("AQ1",$P(X,"^",2),PSNB)=""
S FORMI=$P($G(^PSNDF(50.68,NNN,5)),"^") I FORMI]"" S $P(^PSDRUG(PSNB,"ND"),"^",11)=FORMI
I $P(^PSDRUG(PSNB,0),"^",3)="",$P($G(^PSNDF(50.68,NNN,7)),"^") N CS S CS=$P($G(^PSNDF(50.68,NNN,7)),"^"),$P(^PSDRUG(PSNB,0),"^",3)=$S(CS?1(1"2n",1"3n"):+CS_"C",+CS=2!(+CS=3)&(CS'["C"):+CS_"A",1:CS) K CS
S X="PSNPSS" X ^%ZOSF("TEST") I D ^PSNPSS
K MMM,NNN,FORMI
S X="PSSUTIL" X ^%ZOSF("TEST") I D EN2^PSSUTIL(PSNB,0)
S FLAG=0
I $D(^PS(59.7,1,49.99)),+^(49.99) S CLDA=$P(PSNNODE,"^",3) I $D(^PS(50.605,CLDA)) S $P(^PSDRUG(PSNB,0),"^",2)=$P(^PS(50.605,CLDA,0),"^",1)
I $D(^PSDRUG("APC")) F PP=0:0 S PP=$O(^PSDRUG("APC",PP)) Q:'PP S COD="" F S COD=$O(^PSDRUG("APC",PP,COD)) Q:COD="" I $D(^PSDRUG("APC",PP,COD,PSNB)) D SETAPC
I FLAG=0 S PRIM=$P($G(^PSDRUG(PSNB,2)),"^",6) I PRIM,$D(^PS(50.3,PRIM)) S ^PSDRUG("APC",PRIM,$P(^PSDRUG(PSNB,0),"^",2),PSNB)=""
K ^PSNTRAN(PSNB,0) S $P(^PSNTRAN(0),"^",4)=($P(^PSNTRAN(0),"^",4))-1,$P(^PSNTRAN(0),"^",3)=0
;
I $D(^PSDRUG("AOC")) S PP=0 F S PP=$O(^PSDRUG("AOC",PP)) Q:'PP S COD="" F S COD=$O(^PSDRUG("AOC",PP,COD)) Q:COD="" I $D(^PSDRUG("AOC",PP,COD,PSNB)) K ^PSDRUG("AOC",PP,COD,PSNB)
S PRIM=$P($G(^PSDRUG(PSNB,2)),"^") S:PRIM ^PSDRUG("AOC",PRIM,$P(^PS(50.605,CLDA,0),"^",1),PSNB)=""
I $$PATCH^XPDUTL("PSS*1.0*57") D DRG^PSSHUIDG(PSNB)
N XX,DNSNAM,DNSPORT,DVER,DMFU S XX=""
F XX=0:0 S XX=$O(^PS(59,XX)) Q:'XX D
.S DVER=$$GET1^DIQ(59,XX_",",105,"I"),DMFU=$$GET1^DIQ(59,XX_",",105.2)
.I DVER="2.4" S DNSNAM=$$GET1^DIQ(59,XX_",",2006),DNSPORT=$$GET1^DIQ(59,XX_",",2007) I DNSNAM'=""&(DMFU="YES") D DRG^PSSDGUPD(PSNB,"",DNSNAM,DNSPORT)
Q
SETAPC K ^PSDRUG("APC",PP,COD,PSNB) S ^PSDRUG("APC",PP,$P(^PS(50.605,CLDA,0),"^",1),PSNB)="" S FLAG=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNMRG 5504 printed Dec 13, 2024@02:24:18 Page 2
PSNMRG ;BIR/CCH&WRT-merges NDF fields into PSDRUG ; 04/18/01 14:56
+1 ;;4.0;NATIONAL DRUG FILE;**2,22,27,51,55,59,60,65,84,569**; 30 Oct 98;Build 3
+2 ;
+3 ;Reference to ^PS(50.3 supported by DBIA #2612
+4 ;Reference to ^PSDRUG supported by DBIA #2352,#221
+5 ;Reference to EN2^PSSUTIL supported by DBIA #3107
+6 ;Reference to ^PS(59.7 supported by DBIA #2613
+7 ;Reference to ^PS(59 supported by DBIA #1976
+8 ;IA 3621 - DRG^PSSHUIDG(DA)
+9 ;IA 4394 - DRG^PSSDGUPD(DA) HL7 V.2.4 dispensing machines
+10 ;
+11 WRITE !,"This option will merge NDF fields into your local drug file. This will also",!,"produce an Error Report for entries in the translation file which are not",!,"in the local file if they should exist."
+12 WRITE " These exceptions will not be merged.",!
+13 WRITE !,"You may queue this report if you wish.",!
DVC KILL %ZIS,POP,IOP
SET %ZIS="QM"
SET %ZIS("B")=""
SET %ZIS("A")="Select Printer: "
DO ^%ZIS
if POP
GOTO DONE
if $EXTRACT(IOST)'="P"
WRITE !!,"This report must be run on a printer.",!!
if $EXTRACT(IOST)'="P"
GOTO DVC
IF POP
KILL IOP,POP,IO("Q")
QUIT
QUE IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="ENQ^PSNMRG"
SET ZTDESC="Merge Error Report"
DO ^%ZTLOAD
KILL ZTSK
DO ^%ZISC
QUIT
ENQ USE IO
SET PSNPGCT=0
SET PSNPGLNG=IOSL-6
DO TITLE
DO LOOP
DONE WRITE @IOF
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL PSNPGLNG,PSNPGCT,Y,MJT,POP,VADC,PRIM,FLAG,IOP,IO("Q")
DO ^%ZISC
+1 QUIT
TITLE IF $DATA(IOF)
IF IOF]""
WRITE @IOF
SET PSNPGCT=PSNPGCT+1
+1 WRITE !,?32,"MERGE ERROR REPORT",!
+2 SET Y=DT
XECUTE ^DD("DD")
WRITE !,"Date Printed: ",Y,?73,"Page: ",PSNPGCT,!
+3 WRITE !!,"INTERNAL FILE NUMBER",?30,"VA PRODUCT NAME",!
+4 FOR MJT=1:1:80
WRITE "-"
+5 QUIT
LOOP if $DATA(XRTL)
DO T0^%ZOSV
KILL ^TMP($JOB,"PSN")
FOR PSNB=0:0
SET PSNB=$ORDER(^PSNTRAN(PSNB))
if 'PSNB
QUIT
DO SET
+1 ; STOP
if $DATA(XRT0)
SET XRTN=$TEXT(+0)
if $DATA(XRT0)
DO T1^%ZOSV
+2 IF '$DATA(^TMP($JOB,"PSN"))
WRITE !!,?30,"No Errors Found During Merge",!!!
+3 IF $DATA(^TMP($JOB,"PSN"))
FOR PSNB=0:0
SET PSNB=$ORDER(^TMP($JOB,"PSN",PSNB))
if 'PSNB
QUIT
if $Y+5>IOSL
DO TITLE
WRITE !,?8,PSNB,?30,FRMNAM,!,"***** This entry no longer exists in your local drug file. ***** ",!," This entry will not be merged. ",!
KILL ^PSNTRAN(PSNB,0)
+4 IF $DATA(^TMP("PSNDP",$JOB))
SET DISPNM=""
FOR
SET DISPNM=$ORDER(^TMP("PSNDP",$JOB,DISPNM))
if DISPNM=""
QUIT
if $Y+5>IOSL
DO TITLE
WRITE !,?5,DISPNM,?51,"needs to be rematched to Orderable Item."
+5 IF $DATA(^TMP("PSNAD",$JOB))
SET ADNM=""
FOR
SET ADNM=$ORDER(^TMP("PSNAD",$JOB,ADNM))
if ADNM=""
QUIT
if $Y+5>IOSL
DO TITLE
WRITE !,"Additive ",?12,ADNM,?51,"needs to be rematched to Orderable Item."
+6 IF $DATA(^TMP("PSNSL",$JOB))
SET SLNM=""
FOR
SET SLNM=$ORDER(^TMP("PSNSL",$JOB,SLNM))
if SLNM=""
QUIT
if $Y+5>IOSL
DO TITLE
WRITE !,"Solution ",?12,SLNM,?51,"needs to be rematched to Orderable Item."
KILLIT KILL ANS,CLDA,PSNNODE,PSNB,PSNIO,ZTRTN,FRMNAM,^TMP("PSNAD",$JOB),^TMP("PSNDP",$JOB),^TMP("PSNSL",$JOB),SLNM,ADNM,DISPNM
QUIT
+1 QUIT
SET IF $DATA(PSNFL)
if PSNFL
QUIT
+1 if '$DATA(^PSNTRAN(PSNB,0))
QUIT
if $PIECE(^PSNTRAN(PSNB,0),"^",9)'="Y"
QUIT
IF '$DATA(^PSDRUG(PSNB))
SET FRMNAM=$PIECE(^PSNDF(50.68,$PIECE(^PSNTRAN(PSNB,0),"^",2),0),"^")
SET ^TMP($JOB,"PSN",PSNB,FRMNAM)=""
QUIT
+2 IF $DATA(^PSDRUG("VAC"))
FOR VADC=0:0
SET VADC=$ORDER(^PSDRUG("VAC",VADC))
if 'VADC
QUIT
IF $DATA(^PSDRUG("VAC",VADC,PSNB))
KILL ^PSDRUG("VAC",VADC,PSNB)
+3 SET PSNNODE=^PSNTRAN(PSNB,0)
+4 SET ^PSDRUG(PSNB,"ND")=$PIECE(PSNNODE,"^")_"^"_$PIECE(^PSNDF(50.68,$PIECE(PSNNODE,"^",2),0),"^")_"^"_$PIECE(PSNNODE,"^",2)_"^"_$PIECE(PSNNODE,"^",5)_"^"_$PIECE(PSNNODE,"^",7)_"^"_$PIECE(PSNNODE,"^",3)
+5 if $PIECE(PSNNODE,"^",3)'=""
SET ^PSDRUG("VAC",$PIECE(PSNNODE,"^",3),PSNB)=""
+6 SET PSNEX=$EXTRACT($PIECE(^PSDRUG(PSNB,"ND"),"^",2),1,30)
if PSNEX'=""
SET ^PSDRUG("VAPN",PSNEX,PSNB)=""
KILL PSNEX
+7 IF $PIECE(PSNNODE,"^",1)
SET ^PSDRUG("AND",$PIECE(PSNNODE,"^",1),PSNB)=""
+8 IF $PIECE(PSNNODE,"^",2)
SET ^PSDRUG("APR",$PIECE(PSNNODE,"^",2),PSNB)=""
+9 IF $PIECE($GET(^PSDRUG(PSNB,2)),"^",6)
IF $PIECE(PSNNODE,"^",1)
IF $PIECE(PSNNODE,"^",2)
SET ^PSDRUG("APN",$PIECE($GET(^PSDRUG(PSNB,2)),"^",6),$PIECE(PSNNODE,"^",1)_"A"_$PIECE(PSNNODE,"^",2),PSNB)=""
+10 SET MMM=$PIECE(^PSDRUG(PSNB,"ND"),"^",1)
SET NNN=$PIECE(^PSDRUG(PSNB,"ND"),"^",3)
SET DA=MMM
SET K=NNN
SET X=$$PROD2^PSNAPIS(DA,K)
IF X]""
IF $PIECE(X,"^")]""
SET $PIECE(^PSDRUG(PSNB,"ND"),"^",10)=$PIECE(X,"^",2)
SET ^PSDRUG("AQ1",$PIECE(X,"^",2),PSNB)=""
+11 SET FORMI=$PIECE($GET(^PSNDF(50.68,NNN,5)),"^")
IF FORMI]""
SET $PIECE(^PSDRUG(PSNB,"ND"),"^",11)=FORMI
+12 IF $PIECE(^PSDRUG(PSNB,0),"^",3)=""
IF $PIECE($GET(^PSNDF(50.68,NNN,7)),"^")
NEW CS
SET CS=$PIECE($GET(^PSNDF(50.68,NNN,7)),"^")
SET $PIECE(^PSDRUG(PSNB,0),"^",3)=$SELECT(CS?1(1"2n",1"3n"):+CS_"C",+CS=2!(+CS=3)&(CS'["C"):+CS_"A",1:CS)
KILL CS
+13 SET X="PSNPSS"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO ^PSNPSS
+14 KILL MMM,NNN,FORMI
+15 SET X="PSSUTIL"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO EN2^PSSUTIL(PSNB,0)
+16 SET FLAG=0
+17 IF $DATA(^PS(59.7,1,49.99))
IF +^(49.99)
SET CLDA=$PIECE(PSNNODE,"^",3)
IF $DATA(^PS(50.605,CLDA))
SET $PIECE(^PSDRUG(PSNB,0),"^",2)=$PIECE(^PS(50.605,CLDA,0),"^",1)
+18 IF $DATA(^PSDRUG("APC"))
FOR PP=0:0
SET PP=$ORDER(^PSDRUG("APC",PP))
if 'PP
QUIT
SET COD=""
FOR
SET COD=$ORDER(^PSDRUG("APC",PP,COD))
if COD=""
QUIT
IF $DATA(^PSDRUG("APC",PP,COD,PSNB))
DO SETAPC
+19 IF FLAG=0
SET PRIM=$PIECE($GET(^PSDRUG(PSNB,2)),"^",6)
IF PRIM
IF $DATA(^PS(50.3,PRIM))
SET ^PSDRUG("APC",PRIM,$PIECE(^PSDRUG(PSNB,0),"^",2),PSNB)=""
+20 KILL ^PSNTRAN(PSNB,0)
SET $PIECE(^PSNTRAN(0),"^",4)=($PIECE(^PSNTRAN(0),"^",4))-1
SET $PIECE(^PSNTRAN(0),"^",3)=0
+21 ;
+22 IF $DATA(^PSDRUG("AOC"))
SET PP=0
FOR
SET PP=$ORDER(^PSDRUG("AOC",PP))
if 'PP
QUIT
SET COD=""
FOR
SET COD=$ORDER(^PSDRUG("AOC",PP,COD))
if COD=""
QUIT
IF $DATA(^PSDRUG("AOC",PP,COD,PSNB))
KILL ^PSDRUG("AOC",PP,COD,PSNB)
+23 SET PRIM=$PIECE($GET(^PSDRUG(PSNB,2)),"^")
if PRIM
SET ^PSDRUG("AOC",PRIM,$PIECE(^PS(50.605,CLDA,0),"^",1),PSNB)=""
+24 IF $$PATCH^XPDUTL("PSS*1.0*57")
DO DRG^PSSHUIDG(PSNB)
+25 NEW XX,DNSNAM,DNSPORT,DVER,DMFU
SET XX=""
+26 FOR XX=0:0
SET XX=$ORDER(^PS(59,XX))
if 'XX
QUIT
Begin DoDot:1
+27 SET DVER=$$GET1^DIQ(59,XX_",",105,"I")
SET DMFU=$$GET1^DIQ(59,XX_",",105.2)
+28 IF DVER="2.4"
SET DNSNAM=$$GET1^DIQ(59,XX_",",2006)
SET DNSPORT=$$GET1^DIQ(59,XX_",",2007)
IF DNSNAM'=""&(DMFU="YES")
DO DRG^PSSDGUPD(PSNB,"",DNSNAM,DNSPORT)
End DoDot:1
+29 QUIT
SETAPC KILL ^PSDRUG("APC",PP,COD,PSNB)
SET ^PSDRUG("APC",PP,$PIECE(^PS(50.605,CLDA,0),"^",1),PSNB)=""
SET FLAG=1
+1 QUIT
