- 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 Feb 18, 2025@23:50:35 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