PSN548D ;BIR/DMA-post install routine to load data ; 03 Jan 2018 1:28 PM
;;4.0;NATIONAL DRUG FILE;**548**; 30 Oct 98;Build 134
;
; Reference to ^PSDRUG supported by DBIA #2192
; Reference to PSN^PSSHUIDG supported by DBIA #3621
; Reference to ^GMR(120.8) supported by DBIA #4606
;
N CL,CLA,CMOP,CT,DA,DA1,DIA,DIC,DIE,DIK,DINUM,DR,FDA,FILE,FLDS,GE,GROOT,GROOT1,IENS,IN,INA,IND,INDX,INV,J,JJ,K,LI,LINE,NA,NAME,ND,NEW,NFI,POST,PR,PSN,PSN1,PSN11,PSN21,PSNDF,R1,ROOT,ROOT1,ROOT2,ROOT3,SUBS,VAC,VAIN,VAPN
N X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,XUMF,TREC
N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,PSNMULTI,MJJ,MIENS,MFLDS,OFLDS,OIENS,PSNVAPN
K ^TMP($J),^TMP("PSN",$J),^TMP("PSNN",$J),^TMP("PPSN.WP",$J),^TMP("PPSN.WPXRF",$J)
;
S PSNDF=1,XPDIDTOT=+$G(@XPDGREF@("TREC")),TREC=0
S XUMF=1
;TO ALLOW ADDS TO 56 ,50.416,50.605,50.606, AND 50.6
;MORE ELEGANT CHANGE LATER
;
S FILE=0,GROOT=$NA(@XPDGREF@("DATANT"))
;load new entries first
F S FILE=$O(@GROOT@(FILE)) Q:'FILE S ROOT=$$ROOT^DILFD(FILE) I ROOT]"" S GROOT1=$NA(@GROOT@(FILE)) F JJ=1:2 Q:'$D(@GROOT1@(JJ)) S DIA=@GROOT1@(JJ),NEW=@GROOT1@(JJ+1) D
.S DA=+DIA K FDA,IENS
.I $$GET1^DIQ(FILE,DA,.01)]"" S FDA(FILE,DA_",",.01)=NEW D FILE^DIE("","FDA") Q
.S DINUM=DA,X=NEW,DIC=ROOT,DIC(0)="L",DIC("DR")="S Y=0" K DD,DO D FILE^DICN
.S TREC=TREC+1 I '(TREC#500) D UPDATE^XPDID(TREC)
;
S FILE=0,GROOT=$NA(@XPDGREF@("DATAN"))
;load new multiple entries next
F S FILE=$O(@GROOT@(FILE)) Q:'FILE S ROOT=$$ROOT^DILFD(FILE) I ROOT]"" S GROOT1=$NA(@GROOT@(FILE)) F JJ=1:2 Q:'$D(@GROOT1@(JJ)) S DIA=@GROOT1@(JJ),NEW=@GROOT1@(JJ+1) D
.S IENS=$P(DIA,"^")_",",FLDS=$P(DIA,"^",3),ROOT=FILE K FDA,IEN
.; *** Removing old COPAY TIER
.I FILE=50.68 D
..I (FLDS="45,.01")&(IENS[",1") I $D(^PSNDF(50.68,+DIA,10,0)) S PSNCPCNT=0 D
...F S PSNCPCNT=$O(^PSNDF(50.68,+DIA,10,PSNCPCNT)) Q:PSNCPCNT="" S DIK="^PSNDF(50.68,"_+DIA_",10,",DA=PSNCPCNT,DA(1)=+DIA D ^DIK
..I $P(DIA,"^",3)=102,NEW=0 D HAZWASTE
..;RxNorm - remove deleted data
..I $P(DIA,"^",3)="43,.01",(NEW["DELETE"!(NEW="")) D RXNORMD1(DIA) Q
..I $P(DIA,"^",3)="43,.02,.01",(NEW["DELETE"!(NEW="")) D RXNORMD1(DIA) Q
..;RxNorm - Because the RXCUI is a multiple .01 field, KIDS puts it in a DATAN record. However, edits may come over as DATAO record from PPS-N
..; so the entry needs to be deleted prior to setting the new value. There should only be one RXCUI defined
..I FLDS="43,.02,.01" D
...S SS1="",SS1=$O(^PSNDF(50.68,+DIA,11,"B","RxNorm",SS1))
...Q:SS1=""
...S (SS3,SS2)=0 F S SS2=$O(^PSNDF(50.68,+DIA,11,SS1,1,SS2)) Q:'SS2 S SS3=1
...Q:'SS3
...D RXNORMD2(DIA)
.;
.I $G(PSNMULTI) D
..S (MIENS,MFLDS)="",MIENS=$P(DIA,"^")_",",MFLDS=$P(DIA,"^",3)
..I MFLDS'=""&($P(NEW,"^")'=MIENS) S PSNMULTI=0,^TMP("PPSN.WPXRF",$J,FILE,OIENS,OFLDS)=""
.S IENS=$P(DIA,"^")_",",FLDS=$P(DIA,"^",3),ROOT=FILE K FDA,IEN
.; ***
.K RES1
.I '$G(PSNMULTI) D FIELD^DID(FILE,FLDS,"","TYPE","RES1")
.I $G(RES1("TYPE"))="WORD-PROCESSING"!$G(PSNMULTI) D Q
..I '$G(PSNMULTI) D
...S MJJ=JJ,OIENS=IENS,OFLDS=FLDS
...I $D(^TMP("PPSN.WPXRF",$J,FILE,IENS,FLDS)) K ^TMP("PPSN.WP",$J,FILE,OIENS,OFLDS),^TMP("PPSN.WPXRF",$J,FILE,IENS,FLDS)
..I '$P(DIA,"^",3) S ^TMP("PPSN.WP",$J,FILE,OIENS,OFLDS,MJJ)=$$STRIP(DIA),MJJ=MJJ+1
..I '$P(NEW,"^",3) S ^TMP("PPSN.WP",$J,FILE,OIENS,OFLDS,MJJ)=$$STRIP(NEW),PSNMULTI=1,MJJ=MJJ+1
..I $P(NEW,"^",3)'="" S JJ=JJ-1
.;
.I FLDS["," D
..;it should, but
..S LI=$P(DIA,"^",3) F J=1:1:$L(LI,",")-1 S ROOT=+$P(^DD(ROOT,+$P(LI,",",J),0),"^",2)
..S LI=$P(DIA,"^"),IENS="" F J=$L(LI,","):-1:1 S IENS=IENS_$P(LI,",",J)_","
..S DA=+IENS
.;I $$GET1^DIQ(ROOT,IENS,.01)]"" S FDA(ROOT,IENS,.01)=NEW D FILE^DIE("","FDA") Q
.S FDA(ROOT,"+"_IENS,.01)=NEW,IEN(DA)=DA D UPDATE^DIE("","FDA","IEN")
.S TREC=TREC+1 I '(TREC#500) D UPDATE^XPDID(TREC)
.I FILE=50.68,$P(DIA,"^",3)="14,.01" S ^TMP("PSNN",$J,$P(DIA,"^"))=""
;
S FILE=0,GROOT=$NA(@XPDGREF@("DATAO"))
;now load the rest of the data
F S FILE=$O(@GROOT@(FILE)) Q:'FILE S ROOT=$$ROOT^DILFD(FILE) I ROOT]"" S GROOT1=$NA(@GROOT@(FILE)) F JJ=1:2 Q:'$D(@GROOT1@(JJ)) S DIA=@GROOT1@(JJ),NEW=@GROOT1@(JJ+1) D
.S IENS=$P(DIA,"^")_",",FLDS=$P(DIA,"^",3),ROOT=FILE K FDA,IEN
.I FILE=50.68,($P(DIA,"^",3)=102),NEW=0 D HAZWASTE
.I FLDS["," D
..S LI=$P(DIA,"^",3) F J=1:1:$L(LI,",")-1 S ROOT=+$P(^DD(ROOT,+$P(LI,",",J),0),"^",2)
..S LI=$P(DIA,"^"),IENS="" F J=$L(LI,","):-1:1 S IENS=IENS_$P(LI,",",J)_","
..S FLDS=$P(FLDS,",",$L(FLDS,","))
.S FDA(ROOT,IENS,FLDS)=NEW D FILE^DIE("","FDA")
.S TREC=TREC+1 I '(TREC#500) D UPDATE^XPDID(TREC)
S JJ=0 F S JJ=$O(^TMP("PSNN",$J,JJ)) Q:'JJ S DA=$P(JJ,",",2),DA(1)=+JJ D ING^PSNXREF
;
WP ;
S FILE="" F S FILE=$O(^TMP("PPSN.WP",$J,FILE)) Q:FILE="" D
. S IENS="" F S IENS=$O(^TMP("PPSN.WP",$J,FILE,IENS)) Q:IENS="" D
.. S FLDS="" F S FLDS=$O(^TMP("PPSN.WP",$J,FILE,IENS,FLDS)) Q:FLDS="" D
... K TMP,ERR
... S JJ=0 F S JJ=$O(^TMP("PPSN.WP",$J,FILE,IENS,FLDS,JJ)) Q:'JJ D
.... S TMP(JJ)=^TMP("PPSN.WP",$J,FILE,IENS,FLDS,JJ)
... D WP^DIE(FILE,IENS,FLDS,"","TMP","ERR")
K ^TMP("PPSN.WP",$J)
;
WORD ;
S ROOT1=$NA(@XPDGREF@("WORD")),CT=0,ROOT2=$NA(@ROOT1@(0))
F S CT=$O(@ROOT2) Q:'CT S ROOT2=$NA(@ROOT1@(CT)),NAME=@ROOT2,ROOT3=$NA(@ROOT2@("D")) K @NAME M @NAME=@ROOT3
;
;
MESSAGE ;
K ^TMP($J) M ^TMP($J)=@XPDGREF@("MESSAGE") K ^TMP($J,0)
;
GROUP ;
K XMY S X=$G(@XPDGREF@("GROUP")) I X]"" S XMY("G."_X_"@"_^XMB("NETNAME"))=""
S DA=0 F S DA=$O(^XUSEC("PSNMGR",DA)) Q:'DA S XMY(DA)=""
I $D(DUZ) S XMY(DUZ)=""
;
S XMSUB="DATA UPDATE FOR NDF"
S XMDUZ="NDF MANAGER"
S XMTEXT="^TMP($J," N DIFROM D ^XMD
;
K ^TMP($J) M ^TMP($J)=@XPDGREF@("MESSAGE2") K ^TMP($J,0)
;
K XMY S X=$G(@XPDGREF@("GROUP")) I X]"" S XMY("G."_X_"@"_^XMB("NETNAME"))=""
S DA=0 F S DA=$O(^XUSEC("PSNMGR",DA)) Q:'DA S XMY(DA)=""
I $D(DUZ) S XMY(DUZ)=""
;
S XMSUB="UPDATED INTERACTIONS"
S XMDUZ="NDF MANAGER"
S XMTEXT="^TMP($J," N DIFROM D ^XMD
DRUGFILE ;
;NOW UPDATE LOCAL DRUG FILE
K ^TMP($J)
S PSN=$$PATCH^XPDUTL("PSS*1.0*34"),PSN1=$$PATCH^XPDUTL("PSS*1.0*42")
S ROOT1=$NA(@XPDGREF@("GENERIC")),ROOT2=$NA(@XPDGREF@("PRODUCT")),ROOT3=$NA(@XPDGREF@("POE")),DA=0
S DA=0 F S DA=$O(^PSDRUG(DA)) Q:'DA S X=$G(^PSDRUG(DA,0)) I X]"" S NA=$P(X,"^"),CLA=$P(X,"^",2),INV=$P(X,"^",3)["I",X=$G(^("ND")),IN=$P($G(^("I"),9999999),"^"),INA=IN'>DT,GE=+X,PR=+$P(X,"^",3),CMOP=$P(X,"^",10),VAPN=$P(X,"^",2) I GE I PR D
.S VAIN=$P($G(^PSNDF(50.68,PR,7)),"^",3)
.I $D(@ROOT2@(PR))!VAIN S X="" S:CMOP]"" X=" (CMOP "_CMOP_")" S $E(X,30)=VAPN,$E(X,65)=$$FMTE^XLFDT(VAIN,5),INDX=$S(INA:"I",INV:"X",1:"A") S:IN=9999999 IN="" S ^TMP($J,INDX,NA_"^"_DA_"^"_IN,1)=X,^TMP($J,"^",DA)="" D
..S DIE="^PSDRUG(",DR="20////@;21////@;22////@;23////@;24////@;27////@;29////@;" D ^DIE K DIE,DR
..I PSN I $P($G(^PSDRUG(DA,"DOS")),"^")]""!$O(^("DOS1",0))!$O(^PSDRUG(DA,"DOS2",0)) D LOAD K ^PSDRUG(DA,"DOS"),^("DOS1"),^("DOS2")
..I $P($G(^PSDRUG(DA,3)),"^") S DIE=50,DR="213////0;" D ^DIE K DIE,DR I PSN1 S IND=$O(^PSDRUG(DA,4," "),-1),$P(^(IND,0),"^",6)="NDF Update"
.I PSN,$D(@ROOT3@(PR)) K ^PSDRUG(DA,"DOS"),^("DOS1"),^("DOS2")
.S ND=$G(^PSDRUG(DA,"ND")),PR=$P(ND,"^",3) I PR D
..S NFI=$P($G(^PSNDF(50.68,PR,5)),"^") I $P(ND,"^",11)'=NFI S DIE=50,DR="29////"_NFI_";" D ^DIE
..S VAC=$P($G(^PSNDF(50.68,PR,3)),"^") I VAC S VAC=$P(^PS(50.605,VAC,0),"^"),DIE=50,DR="2////"_VAC_";" D ^DIE
..I $P($G(^PSDRUG(DA,3)),"^"),'$P($G(^PSNDF(50.68,PR,1)),"^",3) S DIE=50,DR="213////0;" D ^DIE K DIE,DR S IND=$O(^PSDRUG(DA,4," "),-1),$P(^(IND,0),"^",6)="NDF Update"
.S TREC=TREC+1 I '(TREC#500) D UPDATE^XPDID(TREC)
;
K ^TMP("PSN",$J) S LINE=1 F INDX="A","X","I" D LOAD1
S XMDUZ="NDF MANAGER",XMSUB="DRUGS UNMATCHED FROM NATIONAL DRUG FILE",XMTEXT="^TMP(""PSN"",$J,"
K XMY S X=$G(@XPDGREF@("GROUP")) I X]"" S XMY("G."_X_"@"_^XMB("NETNAME"))=""
S DA=0 F S DA=$O(^XUSEC("PSNMGR",DA)) Q:'DA S XMY(DA)=""
I $D(DUZ) S XMY(DUZ)=""
N DIFROM D ^XMD I $D(XMZ) S DA=XMZ,DIE=3.9,DR="1.7///P;" D ^DIE
;package specific post install
I $D(@XPDGREF@("POST")) S POST=^("POST") S:POST'["^" POST="^"_POST I @("$T("_POST_")]]""""") D @POST
;
;call to HL7 drug update message
I $T(PSN^PSSHUIDG)]"" I $O(^TMP($J,"^",0)) S ZTRTN="PSN^PSSHUIDG",ZTIO="",ZTDTH=$H,ZTDESC="DRUG UPDATE MESSAGE",ZTSAVE("^TMP($J,""^"",")="" D ^%ZTLOAD
;
REINDEX ;Make sure APC xref is correct
I $T(EN2^GMRAUIX0)']"" G MORE
N SUB,DA,DIK,GMRAIEN,CLASS
S SUB=0 F S SUB=$O(^GMR(120.8,SUB)) Q:'+SUB I $D(^GMR(120.8,SUB,3)) D
.S GMRAIEN=+$P($G(^GMR(120.8,SUB,0)),U) Q:'GMRAIEN
.S CLASS="" F S CLASS=$O(^GMR(120.8,"APC",GMRAIEN,CLASS)) Q:CLASS="" K ^GMR(120.8,"APC",GMRAIEN,CLASS,SUB)
.S DA(1)=SUB
.S DIK="^GMR(120.8,DA(1),3,"
.S DIK(1)=".01^ADRG3"
.D ENALL^DIK ;Reset the drug class xref
;
MORE ;REINDEXING
;now the APD
K ^PS(50.416,"APD") S DA=0 F S DA=$O(^PS(50.416,DA)),K=0 Q:'DA F S K=$O(^PS(50.416,DA,1,K)) Q:'K S X=^(K,0),^PS(50.416,"APD",X,DA)=""
;now the interactions
K ^PS(56,"APD") S DA=0 F S DA=$O(^PS(56,DA)) Q:'DA K PSN1,PSN2 S PSN1=$P(^(DA,0),"^",2),PSN2=$P(^(0),"^",3) D
.S NA="" F S NA=$O(^PS(50.416,PSN1,1,"B",NA)) Q:NA="" S PSN1(NA)=""
.S PSN11=0 F S PSN11=$O(^PS(50.416,"APS",PSN1,PSN11)),NA="" Q:'PSN11 F S NA=$O(^PS(50.416,PSN11,1,"B",NA)) Q:NA="" S PSN1(NA)=""
.S NA="" F S NA=$O(^PS(50.416,PSN2,1,"B",NA)) Q:NA="" S PSN2(NA)=""
.S PSN21=0 F S PSN21=$O(^PS(50.416,"APS",PSN2,PSN21)),NA="" Q:'PSN21 F S NA=$O(^PS(50.416,PSN21,1,"B",NA)) Q:NA="" S PSN2(NA)=""
.S PSN1="" F S PSN1=$O(PSN1(PSN1)),PSN2="" Q:PSN1="" F S PSN2=$O(PSN2(PSN2)) Q:PSN2="" S ^PS(56,"APD",PSN1,PSN2,DA)="",^PS(56,"APD",PSN2,PSN1,DA)=""
;
D ^PSNCLEAN
;
QUIT ;
D UPDATE^XPDID(XPDIDTOT)
K CL,CLA,CMOP,CT,DA,DA1,DIA,DIC,DIE,DIK,DINUM,DR,FDA,FILE,FLDS,GE,GROOT,GROOT1,IENS,IN,INA,IND,INDX,INV,J,JJ,K,LI,LINE,NA,NAME,ND,NEW,NFI,POST,PR,PSN,PSN1,PSN11,PSN21,PSNDF,R1,ROOT,ROOT1,ROOT2,ROOT3,SUBS,VAC,VAIN,VAPN
K X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,XUMF,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
K ^TMP($J),^TMP("PSN",$J),^TMP("PSNN",$J)
Q
;
LOAD ;GET DOSE STUFF
S J=2,X=$G(^PSDRUG(DA,"DOS")) I $P(X,"^"),$D(^PS(50.607,+$P(X,"^",2),0)) S ^TMP($J,INDX,NA_"^"_DA_"^"_IN,J)=" STRENGTH: "_+X_"UNITS: "_$P(^PS(50.607,+$P(X,"^",2),0),"^"),J=J+1
I $O(^PSDRUG(DA,"DOS1",0)) S ^TMP($J,INDX,NA_"^"_DA_"^"_IN,J)=" POSSIBLE DOSES",^(J+1)=" DISP UNITS/DOSE DOSE PACKAGE BCMA UNITS/DOSE",DA1=0,J=J+2 D
.F S DA1=$O(^PSDRUG(DA,"DOS1",DA1)) Q:'DA1 S X=^(DA1,0),^TMP($J,INDX,NA_"^"_DA_"^"_IN,J)=" "_$J($P(X,"^"),4),$E(^(J),25)=$J($P(X,"^",2),4),$E(^(J),35)=$P(X,"^",3),$E(^(J),43)=$P(X,"^",4),J=J+1
I $O(^PSDRUG(DA,"DOS2",0)) S ^TMP($J,INDX,NA_"^"_DA_"^"_IN,J)=" LOCAL POSSIBLE DOSES",^(J+1)=" DOSE PACKAGE BCMA UNITS/DOSE",DA1=0,J=J+2 D
.F S DA1=$O(^PSDRUG(DA,"DOS2",DA1)) Q:'DA1 S X=^(DA1,0),^TMP($J,INDX,NA_"^"_DA_"^"_IN,J)=" "_$P(X,"^"),$E(^(J),55)=$P(X,"^",2),$E(^(J),71)=$P(X,"^",3),J=J+1
Q
;
LOAD1 ;BUILD THE MESSAGE
S ^TMP("PSN",$J,LINE,0)=" ",LINE=LINE+1
S ^TMP("PSN",$J,LINE,0)="The following "_$S(INDX="A":"active",INDX="X":"investigational",1:"inactive")_" entries in your DRUG file (#50) have been",LINE=LINE+1
S J=0 F S J=$O(@XPDGREF@("TEXT",J)) Q:'J S ^TMP("PSN",$J,LINE,0)=@XPDGREF@("TEXT",J),LINE=LINE+1
;I INDX'="I" S LINE=LINE-1,^(0)=$P(^TMP("PSN",$J,LINE-2,0),"IN"),^TMP("PSN",$J,LINE-1,0)=" "
S NA="" I $O(^TMP($J,INDX,NA))="" S ^TMP("PSN",$J,LINE,0)=" NONE",LINE=LINE+1 Q
F S NA=$O(^TMP($J,INDX,NA)) Q:NA="" S X=^(NA,1),^TMP("PSN",$J,LINE,0)=$P(NA,"^"),$E(^(0),55)=$P(NA,"^",2) S:INDX="I" $E(^(0),62)=$$FMTE^XLFDT($P(NA,"^",3),5) S LINE=LINE+1,^TMP("PSN",$J,LINE,0)=$P(X,"^"),LINE=LINE+1 S J=1 D
.F S J=$O(^TMP($J,INDX,NA,J)) Q:'J S ^TMP("PSN",$J,LINE,0)=^(J),LINE=LINE+1
Q
;
HAZWASTE ;
;HAZARDOUS TO DISPOSE FIELD 102 = ZERO; KILL FIELDS 103,104,105
N DA,DIE S (DA,DIE)=""
S DA=+$P(DIA,"^"),DIE="^PSNDF(50.68,",DR="103///@;104///@;105///@" D ^DIE
Q
;
STRIP(X) ; Strip control characters
N I,Y
S Y="" F I=1:1:$L(X) I $A(X,I)>31,$A(X,I)<127 S Y=Y_$E(X,I)
Q Y
;
RXNORMD1(DIA) ;RxNorm deleted
N DIK,DA,X
S DA=$P($P(DIA,"^"),",",2),DA(1)=$P($P(DIA,"^"),",")
S X="",X=$G(^PSNDF(50.68,DA(1),11,DA,0))
Q:X'="RxNorm"
S DIK="^PSNDF(50.68,"_DA(1)_",11,"
D ^DIK
Q
;
RXNORMD2(DIA) ;RxNorm deleted
N DIK,DA,OVAL,CNT,CNT2,PSNVAPN
S PSNVAPN=+DIA
S (CNT2,DA)=$P($P(DIA,"^"),",",3),(CNT,DA(1))=$P($P(DIA,"^"),",",2),DA(2)=$P($P(DIA,"^"),",")
S OVAL=$G(^PSNDF(50.68,PSNVAPN,11,DA(1),1,DA,0))
S DIK="^PSNDF(50.68,"_PSNVAPN_",11,"_DA(1)_",1,",DA=CNT2,DA(1)=CNT,DA(2)=PSNVAPN
D ^DIK
I OVAL'="" K ^PSNDF(50.68,PSNVAPN,11,CNT,CNT2,"B",OVAL)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSN548D 12757 printed Dec 13, 2024@02:23:29 Page 2
PSN548D ;BIR/DMA-post install routine to load data ; 03 Jan 2018 1:28 PM
+1 ;;4.0;NATIONAL DRUG FILE;**548**; 30 Oct 98;Build 134
+2 ;
+3 ; Reference to ^PSDRUG supported by DBIA #2192
+4 ; Reference to PSN^PSSHUIDG supported by DBIA #3621
+5 ; Reference to ^GMR(120.8) supported by DBIA #4606
+6 ;
+7 NEW CL,CLA,CMOP,CT,DA,DA1,DIA,DIC,DIE,DIK,DINUM,DR,FDA,FILE,FLDS,GE,GROOT,GROOT1,IENS,IN,INA,IND,INDX,INV,J,JJ,K,LI,LINE,NA,NAME,ND,NEW,NFI,POST,PR,PSN,PSN1,PSN11,PSN21,PSNDF,R1,ROOT,ROOT1,ROOT2,ROOT3,SUBS,VAC,VAIN,VAPN
+8 NEW X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,XUMF,TREC
+9 NEW ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,PSNMULTI,MJJ,MIENS,MFLDS,OFLDS,OIENS,PSNVAPN
+10 KILL ^TMP($JOB),^TMP("PSN",$JOB),^TMP("PSNN",$JOB),^TMP("PPSN.WP",$JOB),^TMP("PPSN.WPXRF",$JOB)
+11 ;
+12 SET PSNDF=1
SET XPDIDTOT=+$GET(@XPDGREF@("TREC"))
SET TREC=0
+13 SET XUMF=1
+14 ;TO ALLOW ADDS TO 56 ,50.416,50.605,50.606, AND 50.6
+15 ;MORE ELEGANT CHANGE LATER
+16 ;
+17 SET FILE=0
SET GROOT=$NAME(@XPDGREF@("DATANT"))
+18 ;load new entries first
+19 FOR
SET FILE=$ORDER(@GROOT@(FILE))
if 'FILE
QUIT
SET ROOT=$$ROOT^DILFD(FILE)
IF ROOT]""
SET GROOT1=$NAME(@GROOT@(FILE))
FOR JJ=1:2
if '$DATA(@GROOT1@(JJ))
QUIT
SET DIA=@GROOT1@(JJ)
SET NEW=@GROOT1@(JJ+1)
Begin DoDot:1
+20 SET DA=+DIA
KILL FDA,IENS
+21 IF $$GET1^DIQ(FILE,DA,.01)]""
SET FDA(FILE,DA_",",.01)=NEW
DO FILE^DIE("","FDA")
QUIT
+22 SET DINUM=DA
SET X=NEW
SET DIC=ROOT
SET DIC(0)="L"
SET DIC("DR")="S Y=0"
KILL DD,DO
DO FILE^DICN
+23 SET TREC=TREC+1
IF '(TREC#500)
DO UPDATE^XPDID(TREC)
End DoDot:1
+24 ;
+25 SET FILE=0
SET GROOT=$NAME(@XPDGREF@("DATAN"))
+26 ;load new multiple entries next
+27 FOR
SET FILE=$ORDER(@GROOT@(FILE))
if 'FILE
QUIT
SET ROOT=$$ROOT^DILFD(FILE)
IF ROOT]""
SET GROOT1=$NAME(@GROOT@(FILE))
FOR JJ=1:2
if '$DATA(@GROOT1@(JJ))
QUIT
SET DIA=@GROOT1@(JJ)
SET NEW=@GROOT1@(JJ+1)
Begin DoDot:1
+28 SET IENS=$PIECE(DIA,"^")_","
SET FLDS=$PIECE(DIA,"^",3)
SET ROOT=FILE
KILL FDA,IEN
+29 ; *** Removing old COPAY TIER
+30 IF FILE=50.68
Begin DoDot:2
+31 IF (FLDS="45,.01")&(IENS[",1")
IF $DATA(^PSNDF(50.68,+DIA,10,0))
SET PSNCPCNT=0
Begin DoDot:3
+32 FOR
SET PSNCPCNT=$ORDER(^PSNDF(50.68,+DIA,10,PSNCPCNT))
if PSNCPCNT=""
QUIT
SET DIK="^PSNDF(50.68,"_+DIA_",10,"
SET DA=PSNCPCNT
SET DA(1)=+DIA
DO ^DIK
End DoDot:3
+33 IF $PIECE(DIA,"^",3)=102
IF NEW=0
DO HAZWASTE
+34 ;RxNorm - remove deleted data
+35 IF $PIECE(DIA,"^",3)="43,.01"
IF (NEW["DELETE"!(NEW=""))
DO RXNORMD1(DIA)
QUIT
+36 IF $PIECE(DIA,"^",3)="43,.02,.01"
IF (NEW["DELETE"!(NEW=""))
DO RXNORMD1(DIA)
QUIT
+37 ;RxNorm - Because the RXCUI is a multiple .01 field, KIDS puts it in a DATAN record. However, edits may come over as DATAO record from PPS-N
+38 ; so the entry needs to be deleted prior to setting the new value. There should only be one RXCUI defined
+39 IF FLDS="43,.02,.01"
Begin DoDot:3
+40 SET SS1=""
SET SS1=$ORDER(^PSNDF(50.68,+DIA,11,"B","RxNorm",SS1))
+41 if SS1=""
QUIT
+42 SET (SS3,SS2)=0
FOR
SET SS2=$ORDER(^PSNDF(50.68,+DIA,11,SS1,1,SS2))
if 'SS2
QUIT
SET SS3=1
+43 if 'SS3
QUIT
+44 DO RXNORMD2(DIA)
End DoDot:3
End DoDot:2
+45 ;
+46 IF $GET(PSNMULTI)
Begin DoDot:2
+47 SET (MIENS,MFLDS)=""
SET MIENS=$PIECE(DIA,"^")_","
SET MFLDS=$PIECE(DIA,"^",3)
+48 IF MFLDS'=""&($PIECE(NEW,"^")'=MIENS)
SET PSNMULTI=0
SET ^TMP("PPSN.WPXRF",$JOB,FILE,OIENS,OFLDS)=""
End DoDot:2
+49 SET IENS=$PIECE(DIA,"^")_","
SET FLDS=$PIECE(DIA,"^",3)
SET ROOT=FILE
KILL FDA,IEN
+50 ; ***
+51 KILL RES1
+52 IF '$GET(PSNMULTI)
DO FIELD^DID(FILE,FLDS,"","TYPE","RES1")
+53 IF $GET(RES1("TYPE"))="WORD-PROCESSING"!$GET(PSNMULTI)
Begin DoDot:2
+54 IF '$GET(PSNMULTI)
Begin DoDot:3
+55 SET MJJ=JJ
SET OIENS=IENS
SET OFLDS=FLDS
+56 IF $DATA(^TMP("PPSN.WPXRF",$JOB,FILE,IENS,FLDS))
KILL ^TMP("PPSN.WP",$JOB,FILE,OIENS,OFLDS),^TMP("PPSN.WPXRF",$JOB,FILE,IENS,FLDS)
End DoDot:3
+57 IF '$PIECE(DIA,"^",3)
SET ^TMP("PPSN.WP",$JOB,FILE,OIENS,OFLDS,MJJ)=$$STRIP(DIA)
SET MJJ=MJJ+1
+58 IF '$PIECE(NEW,"^",3)
SET ^TMP("PPSN.WP",$JOB,FILE,OIENS,OFLDS,MJJ)=$$STRIP(NEW)
SET PSNMULTI=1
SET MJJ=MJJ+1
+59 IF $PIECE(NEW,"^",3)'=""
SET JJ=JJ-1
End DoDot:2
QUIT
+60 ;
+61 IF FLDS[","
Begin DoDot:2
+62 ;it should, but
+63 SET LI=$PIECE(DIA,"^",3)
FOR J=1:1:$LENGTH(LI,",")-1
SET ROOT=+$PIECE(^DD(ROOT,+$PIECE(LI,",",J),0),"^",2)
+64 SET LI=$PIECE(DIA,"^")
SET IENS=""
FOR J=$LENGTH(LI,","):-1:1
SET IENS=IENS_$PIECE(LI,",",J)_","
+65 SET DA=+IENS
End DoDot:2
+66 ;I $$GET1^DIQ(ROOT,IENS,.01)]"" S FDA(ROOT,IENS,.01)=NEW D FILE^DIE("","FDA") Q
+67 SET FDA(ROOT,"+"_IENS,.01)=NEW
SET IEN(DA)=DA
DO UPDATE^DIE("","FDA","IEN")
+68 SET TREC=TREC+1
IF '(TREC#500)
DO UPDATE^XPDID(TREC)
+69 IF FILE=50.68
IF $PIECE(DIA,"^",3)="14,.01"
SET ^TMP("PSNN",$JOB,$PIECE(DIA,"^"))=""
End DoDot:1
+70 ;
+71 SET FILE=0
SET GROOT=$NAME(@XPDGREF@("DATAO"))
+72 ;now load the rest of the data
+73 FOR
SET FILE=$ORDER(@GROOT@(FILE))
if 'FILE
QUIT
SET ROOT=$$ROOT^DILFD(FILE)
IF ROOT]""
SET GROOT1=$NAME(@GROOT@(FILE))
FOR JJ=1:2
if '$DATA(@GROOT1@(JJ))
QUIT
SET DIA=@GROOT1@(JJ)
SET NEW=@GROOT1@(JJ+1)
Begin DoDot:1
+74 SET IENS=$PIECE(DIA,"^")_","
SET FLDS=$PIECE(DIA,"^",3)
SET ROOT=FILE
KILL FDA,IEN
+75 IF FILE=50.68
IF ($PIECE(DIA,"^",3)=102)
IF NEW=0
DO HAZWASTE
+76 IF FLDS[","
Begin DoDot:2
+77 SET LI=$PIECE(DIA,"^",3)
FOR J=1:1:$LENGTH(LI,",")-1
SET ROOT=+$PIECE(^DD(ROOT,+$PIECE(LI,",",J),0),"^",2)
+78 SET LI=$PIECE(DIA,"^")
SET IENS=""
FOR J=$LENGTH(LI,","):-1:1
SET IENS=IENS_$PIECE(LI,",",J)_","
+79 SET FLDS=$PIECE(FLDS,",",$LENGTH(FLDS,","))
End DoDot:2
+80 SET FDA(ROOT,IENS,FLDS)=NEW
DO FILE^DIE("","FDA")
+81 SET TREC=TREC+1
IF '(TREC#500)
DO UPDATE^XPDID(TREC)
End DoDot:1
+82 SET JJ=0
FOR
SET JJ=$ORDER(^TMP("PSNN",$JOB,JJ))
if 'JJ
QUIT
SET DA=$PIECE(JJ,",",2)
SET DA(1)=+JJ
DO ING^PSNXREF
+83 ;
WP ;
+1 SET FILE=""
FOR
SET FILE=$ORDER(^TMP("PPSN.WP",$JOB,FILE))
if FILE=""
QUIT
Begin DoDot:1
+2 SET IENS=""
FOR
SET IENS=$ORDER(^TMP("PPSN.WP",$JOB,FILE,IENS))
if IENS=""
QUIT
Begin DoDot:2
+3 SET FLDS=""
FOR
SET FLDS=$ORDER(^TMP("PPSN.WP",$JOB,FILE,IENS,FLDS))
if FLDS=""
QUIT
Begin DoDot:3
+4 KILL TMP,ERR
+5 SET JJ=0
FOR
SET JJ=$ORDER(^TMP("PPSN.WP",$JOB,FILE,IENS,FLDS,JJ))
if 'JJ
QUIT
Begin DoDot:4
+6 SET TMP(JJ)=^TMP("PPSN.WP",$JOB,FILE,IENS,FLDS,JJ)
End DoDot:4
+7 DO WP^DIE(FILE,IENS,FLDS,"","TMP","ERR")
End DoDot:3
End DoDot:2
End DoDot:1
+8 KILL ^TMP("PPSN.WP",$JOB)
+9 ;
WORD ;
+1 SET ROOT1=$NAME(@XPDGREF@("WORD"))
SET CT=0
SET ROOT2=$NAME(@ROOT1@(0))
+2 FOR
SET CT=$ORDER(@ROOT2)
if 'CT
QUIT
SET ROOT2=$NAME(@ROOT1@(CT))
SET NAME=@ROOT2
SET ROOT3=$NAME(@ROOT2@("D"))
KILL @NAME
MERGE @NAME=@ROOT3
+3 ;
+4 ;
MESSAGE ;
+1 KILL ^TMP($JOB)
MERGE ^TMP($JOB)=@XPDGREF@("MESSAGE")
KILL ^TMP($JOB,0)
+2 ;
GROUP ;
+1 KILL XMY
SET X=$GET(@XPDGREF@("GROUP"))
IF X]""
SET XMY("G."_X_"@"_^XMB("NETNAME"))=""
+2 SET DA=0
FOR
SET DA=$ORDER(^XUSEC("PSNMGR",DA))
if 'DA
QUIT
SET XMY(DA)=""
+3 IF $DATA(DUZ)
SET XMY(DUZ)=""
+4 ;
+5 SET XMSUB="DATA UPDATE FOR NDF"
+6 SET XMDUZ="NDF MANAGER"
+7 SET XMTEXT="^TMP($J,"
NEW DIFROM
DO ^XMD
+8 ;
+9 KILL ^TMP($JOB)
MERGE ^TMP($JOB)=@XPDGREF@("MESSAGE2")
KILL ^TMP($JOB,0)
+10 ;
+11 KILL XMY
SET X=$GET(@XPDGREF@("GROUP"))
IF X]""
SET XMY("G."_X_"@"_^XMB("NETNAME"))=""
+12 SET DA=0
FOR
SET DA=$ORDER(^XUSEC("PSNMGR",DA))
if 'DA
QUIT
SET XMY(DA)=""
+13 IF $DATA(DUZ)
SET XMY(DUZ)=""
+14 ;
+15 SET XMSUB="UPDATED INTERACTIONS"
+16 SET XMDUZ="NDF MANAGER"
+17 SET XMTEXT="^TMP($J,"
NEW DIFROM
DO ^XMD
DRUGFILE ;
+1 ;NOW UPDATE LOCAL DRUG FILE
+2 KILL ^TMP($JOB)
+3 SET PSN=$$PATCH^XPDUTL("PSS*1.0*34")
SET PSN1=$$PATCH^XPDUTL("PSS*1.0*42")
+4 SET ROOT1=$NAME(@XPDGREF@("GENERIC"))
SET ROOT2=$NAME(@XPDGREF@("PRODUCT"))
SET ROOT3=$NAME(@XPDGREF@("POE"))
SET DA=0
+5 SET DA=0
FOR
SET DA=$ORDER(^PSDRUG(DA))
if 'DA
QUIT
SET X=$GET(^PSDRUG(DA,0))
IF X]""
SET NA=$PIECE(X,"^")
SET CLA=$PIECE(X,"^",2)
SET INV=$PIECE(X,"^",3)["I"
SET X=$GET(^("ND"))
SET IN=$PIECE($GET(^("I"),9999999),"^")
SET INA=IN'>DT
SET GE=+X
SET PR=+$PIECE(X,"^",3)
SET CMOP=$PIECE(X,"^",10)
SET VAPN=$PIECE(X,"^",2)
IF GE
IF PR
Begin DoDot:1
+6 SET VAIN=$PIECE($GET(^PSNDF(50.68,PR,7)),"^",3)
+7 IF $DATA(@ROOT2@(PR))!VAIN
SET X=""
if CMOP]""
SET X=" (CMOP "_CMOP_")"
SET $EXTRACT(X,30)=VAPN
SET $EXTRACT(X,65)=$$FMTE^XLFDT(VAIN,5)
SET INDX=$SELECT(INA:"I",INV:"X",1:"A")
if IN=9999999
SET IN=""
SET ^TMP($JOB,INDX,NA_"^"_DA_"^"_IN,1)=X
SET ^TMP($JOB,"^",DA)=""
Begin DoDot:2
+8 SET DIE="^PSDRUG("
SET DR="20////@;21////@;22////@;23////@;24////@;27////@;29////@;"
DO ^DIE
KILL DIE,DR
+9 IF PSN
IF $PIECE($GET(^PSDRUG(DA,"DOS")),"^")]""!$ORDER(^("DOS1",0))!$ORDER(^PSDRUG(DA,"DOS2",0))
DO LOAD
KILL ^PSDRUG(DA,"DOS"),^("DOS1"),^("DOS2")
+10 IF $PIECE($GET(^PSDRUG(DA,3)),"^")
SET DIE=50
SET DR="213////0;"
DO ^DIE
KILL DIE,DR
IF PSN1
SET IND=$ORDER(^PSDRUG(DA,4," "),-1)
SET $PIECE(^(IND,0),"^",6)="NDF Update"
End DoDot:2
+11 IF PSN
IF $DATA(@ROOT3@(PR))
KILL ^PSDRUG(DA,"DOS"),^("DOS1"),^("DOS2")
+12 SET ND=$GET(^PSDRUG(DA,"ND"))
SET PR=$PIECE(ND,"^",3)
IF PR
Begin DoDot:2
+13 SET NFI=$PIECE($GET(^PSNDF(50.68,PR,5)),"^")
IF $PIECE(ND,"^",11)'=NFI
SET DIE=50
SET DR="29////"_NFI_";"
DO ^DIE
+14 SET VAC=$PIECE($GET(^PSNDF(50.68,PR,3)),"^")
IF VAC
SET VAC=$PIECE(^PS(50.605,VAC,0),"^")
SET DIE=50
SET DR="2////"_VAC_";"
DO ^DIE
+15 IF $PIECE($GET(^PSDRUG(DA,3)),"^")
IF '$PIECE($GET(^PSNDF(50.68,PR,1)),"^",3)
SET DIE=50
SET DR="213////0;"
DO ^DIE
KILL DIE,DR
SET IND=$ORDER(^PSDRUG(DA,4," "),-1)
SET $PIECE(^(IND,0),"^",6)="NDF Update"
End DoDot:2
+16 SET TREC=TREC+1
IF '(TREC#500)
DO UPDATE^XPDID(TREC)
End DoDot:1
+17 ;
+18 KILL ^TMP("PSN",$JOB)
SET LINE=1
FOR INDX="A","X","I"
DO LOAD1
+19 SET XMDUZ="NDF MANAGER"
SET XMSUB="DRUGS UNMATCHED FROM NATIONAL DRUG FILE"
SET XMTEXT="^TMP(""PSN"",$J,"
+20 KILL XMY
SET X=$GET(@XPDGREF@("GROUP"))
IF X]""
SET XMY("G."_X_"@"_^XMB("NETNAME"))=""
+21 SET DA=0
FOR
SET DA=$ORDER(^XUSEC("PSNMGR",DA))
if 'DA
QUIT
SET XMY(DA)=""
+22 IF $DATA(DUZ)
SET XMY(DUZ)=""
+23 NEW DIFROM
DO ^XMD
IF $DATA(XMZ)
SET DA=XMZ
SET DIE=3.9
SET DR="1.7///P;"
DO ^DIE
+24 ;package specific post install
+25 IF $DATA(@XPDGREF@("POST"))
SET POST=^("POST")
if POST'["^"
SET POST="^"_POST
IF @("$T("_POST_")]]""""")
DO @POST
+26 ;
+27 ;call to HL7 drug update message
+28 IF $TEXT(PSN^PSSHUIDG)]""
IF $ORDER(^TMP($JOB,"^",0))
SET ZTRTN="PSN^PSSHUIDG"
SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTDESC="DRUG UPDATE MESSAGE"
SET ZTSAVE("^TMP($J,""^"",")=""
DO ^%ZTLOAD
+29 ;
REINDEX ;Make sure APC xref is correct
+1 IF $TEXT(EN2^GMRAUIX0)']""
GOTO MORE
+2 NEW SUB,DA,DIK,GMRAIEN,CLASS
+3 SET SUB=0
FOR
SET SUB=$ORDER(^GMR(120.8,SUB))
if '+SUB
QUIT
IF $DATA(^GMR(120.8,SUB,3))
Begin DoDot:1
+4 SET GMRAIEN=+$PIECE($GET(^GMR(120.8,SUB,0)),U)
if 'GMRAIEN
QUIT
+5 SET CLASS=""
FOR
SET CLASS=$ORDER(^GMR(120.8,"APC",GMRAIEN,CLASS))
if CLASS=""
QUIT
KILL ^GMR(120.8,"APC",GMRAIEN,CLASS,SUB)
+6 SET DA(1)=SUB
+7 SET DIK="^GMR(120.8,DA(1),3,"
+8 SET DIK(1)=".01^ADRG3"
+9 ;Reset the drug class xref
DO ENALL^DIK
End DoDot:1
+10 ;
MORE ;REINDEXING
+1 ;now the APD
+2 KILL ^PS(50.416,"APD")
SET DA=0
FOR
SET DA=$ORDER(^PS(50.416,DA))
SET K=0
if 'DA
QUIT
FOR
SET K=$ORDER(^PS(50.416,DA,1,K))
if 'K
QUIT
SET X=^(K,0)
SET ^PS(50.416,"APD",X,DA)=""
+3 ;now the interactions
+4 KILL ^PS(56,"APD")
SET DA=0
FOR
SET DA=$ORDER(^PS(56,DA))
if 'DA
QUIT
KILL PSN1,PSN2
SET PSN1=$PIECE(^(DA,0),"^",2)
SET PSN2=$PIECE(^(0),"^",3)
Begin DoDot:1
+5 SET NA=""
FOR
SET NA=$ORDER(^PS(50.416,PSN1,1,"B",NA))
if NA=""
QUIT
SET PSN1(NA)=""
+6 SET PSN11=0
FOR
SET PSN11=$ORDER(^PS(50.416,"APS",PSN1,PSN11))
SET NA=""
if 'PSN11
QUIT
FOR
SET NA=$ORDER(^PS(50.416,PSN11,1,"B",NA))
if NA=""
QUIT
SET PSN1(NA)=""
+7 SET NA=""
FOR
SET NA=$ORDER(^PS(50.416,PSN2,1,"B",NA))
if NA=""
QUIT
SET PSN2(NA)=""
+8 SET PSN21=0
FOR
SET PSN21=$ORDER(^PS(50.416,"APS",PSN2,PSN21))
SET NA=""
if 'PSN21
QUIT
FOR
SET NA=$ORDER(^PS(50.416,PSN21,1,"B",NA))
if NA=""
QUIT
SET PSN2(NA)=""
+9 SET PSN1=""
FOR
SET PSN1=$ORDER(PSN1(PSN1))
SET PSN2=""
if PSN1=""
QUIT
FOR
SET PSN2=$ORDER(PSN2(PSN2))
if PSN2=""
QUIT
SET ^PS(56,"APD",PSN1,PSN2,DA)=""
SET ^PS(56,"APD",PSN2,PSN1,DA)=""
End DoDot:1
+10 ;
+11 DO ^PSNCLEAN
+12 ;
QUIT ;
+1 DO UPDATE^XPDID(XPDIDTOT)
+2 KILL CL,CLA,CMOP,CT,DA,DA1,DIA,DIC,DIE,DIK,DINUM,DR,FDA,FILE,FLDS,GE,GROOT,GROOT1,IENS,IN,INA,IND,INDX,INV,J,JJ,K,LI,LINE,NA,NAME,ND,NEW,NFI,POST,PR,PSN,PSN1,PSN11,PSN21,PSNDF,R1,ROOT,ROOT1,ROOT2,ROOT3,SUBS,VAC,VAIN,VAPN
+3 KILL X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,XUMF,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+4 KILL ^TMP($JOB),^TMP("PSN",$JOB),^TMP("PSNN",$JOB)
+5 QUIT
+6 ;
LOAD ;GET DOSE STUFF
+1 SET J=2
SET X=$GET(^PSDRUG(DA,"DOS"))
IF $PIECE(X,"^")
IF $DATA(^PS(50.607,+$PIECE(X,"^",2),0))
SET ^TMP($JOB,INDX,NA_"^"_DA_"^"_IN,J)=" STRENGTH: "_+X_"UNITS: "_$PIECE(^PS(50.607,+$PIECE(X,"^",2),0),"^")
SET J=J+1
+2 IF $ORDER(^PSDRUG(DA,"DOS1",0))
SET ^TMP($JOB,INDX,NA_"^"_DA_"^"_IN,J)=" POSSIBLE DOSES"
SET ^(J+1)=" DISP UNITS/DOSE DOSE PACKAGE BCMA UNITS/DOSE"
SET DA1=0
SET J=J+2
Begin DoDot:1
+3 FOR
SET DA1=$ORDER(^PSDRUG(DA,"DOS1",DA1))
if 'DA1
QUIT
SET X=^(DA1,0)
SET ^TMP($JOB,INDX,NA_"^"_DA_"^"_IN,J)=" "_$JUSTIFY($PIECE(X,"^"),4)
SET $EXTRACT(^(J),25)=$JUSTIFY($PIECE(X,"^",2),4)
SET $EXTRACT(^(J),35)=$PIECE(X,"^",3)
SET $EXTRACT(^(J),43)=$PIECE(X,"^",4)
SET J=J+1
End DoDot:1
+4 IF $ORDER(^PSDRUG(DA,"DOS2",0))
SET ^TMP($JOB,INDX,NA_"^"_DA_"^"_IN,J)=" LOCAL POSSIBLE DOSES"
SET ^(J+1)=" DOSE PACKAGE BCMA UNITS/DOSE"
SET DA1=0
SET J=J+2
Begin DoDot:1
+5 FOR
SET DA1=$ORDER(^PSDRUG(DA,"DOS2",DA1))
if 'DA1
QUIT
SET X=^(DA1,0)
SET ^TMP($JOB,INDX,NA_"^"_DA_"^"_IN,J)=" "_$PIECE(X,"^")
SET $EXTRACT(^(J),55)=$PIECE(X,"^",2)
SET $EXTRACT(^(J),71)=$PIECE(X,"^",3)
SET J=J+1
End DoDot:1
+6 QUIT
+7 ;
LOAD1 ;BUILD THE MESSAGE
+1 SET ^TMP("PSN",$JOB,LINE,0)=" "
SET LINE=LINE+1
+2 SET ^TMP("PSN",$JOB,LINE,0)="The following "_$SELECT(INDX="A":"active",INDX="X":"investigational",1:"inactive")_" entries in your DRUG file (#50) have been"
SET LINE=LINE+1
+3 SET J=0
FOR
SET J=$ORDER(@XPDGREF@("TEXT",J))
if 'J
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=@XPDGREF@("TEXT",J)
SET LINE=LINE+1
+4 ;I INDX'="I" S LINE=LINE-1,^(0)=$P(^TMP("PSN",$J,LINE-2,0),"IN"),^TMP("PSN",$J,LINE-1,0)=" "
+5 SET NA=""
IF $ORDER(^TMP($JOB,INDX,NA))=""
SET ^TMP("PSN",$JOB,LINE,0)=" NONE"
SET LINE=LINE+1
QUIT
+6 FOR
SET NA=$ORDER(^TMP($JOB,INDX,NA))
if NA=""
QUIT
SET X=^(NA,1)
SET ^TMP("PSN",$JOB,LINE,0)=$PIECE(NA,"^")
SET $EXTRACT(^(0),55)=$PIECE(NA,"^",2)
if INDX="I"
SET $EXTRACT(^(0),62)=$$FMTE^XLFDT($PIECE(NA,"^",3),5)
SET LINE=LINE+1
SET ^TMP("PSN",$JOB,LINE,0)=$PIECE(X,"^")
SET LINE=LINE+1
SET J=1
Begin DoDot:1
+7 FOR
SET J=$ORDER(^TMP($JOB,INDX,NA,J))
if 'J
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=^(J)
SET LINE=LINE+1
End DoDot:1
+8 QUIT
+9 ;
HAZWASTE ;
+1 ;HAZARDOUS TO DISPOSE FIELD 102 = ZERO; KILL FIELDS 103,104,105
+2 NEW DA,DIE
SET (DA,DIE)=""
+3 SET DA=+$PIECE(DIA,"^")
SET DIE="^PSNDF(50.68,"
SET DR="103///@;104///@;105///@"
DO ^DIE
+4 QUIT
+5 ;
STRIP(X) ; Strip control characters
+1 NEW I,Y
+2 SET Y=""
FOR I=1:1:$LENGTH(X)
IF $ASCII(X,I)>31
IF $ASCII(X,I)<127
SET Y=Y_$EXTRACT(X,I)
+3 QUIT Y
+4 ;
RXNORMD1(DIA) ;RxNorm deleted
+1 NEW DIK,DA,X
+2 SET DA=$PIECE($PIECE(DIA,"^"),",",2)
SET DA(1)=$PIECE($PIECE(DIA,"^"),",")
+3 SET X=""
SET X=$GET(^PSNDF(50.68,DA(1),11,DA,0))
+4 if X'="RxNorm"
QUIT
+5 SET DIK="^PSNDF(50.68,"_DA(1)_",11,"
+6 DO ^DIK
+7 QUIT
+8 ;
RXNORMD2(DIA) ;RxNorm deleted
+1 NEW DIK,DA,OVAL,CNT,CNT2,PSNVAPN
+2 SET PSNVAPN=+DIA
+3 SET (CNT2,DA)=$PIECE($PIECE(DIA,"^"),",",3)
SET (CNT,DA(1))=$PIECE($PIECE(DIA,"^"),",",2)
SET DA(2)=$PIECE($PIECE(DIA,"^"),",")
+4 SET OVAL=$GET(^PSNDF(50.68,PSNVAPN,11,DA(1),1,DA,0))
+5 SET DIK="^PSNDF(50.68,"_PSNVAPN_",11,"_DA(1)_",1,"
SET DA=CNT2
SET DA(1)=CNT
SET DA(2)=PSNVAPN
+6 DO ^DIK
+7 IF OVAL'=""
KILL ^PSNDF(50.68,PSNVAPN,11,CNT,CNT2,"B",OVAL)
+8 QUIT
