PSN401D ;BIR/DMA-post install routine to load data ; 04 Jun 2014 10:40 AM
;;4.0;NATIONAL DRUG FILE;**401**; 30 Oct 98;Build 89
;
; 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
K ^TMP($J),^TMP("PSN",$J),^TMP("PSNN",$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
.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 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
;
;
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(@ROOT1@(GE))!$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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSN401D 9550 printed Sep 23, 2025@19:56:50 Page 2
PSN401D ;BIR/DMA-post install routine to load data ; 04 Jun 2014 10:40 AM
+1 ;;4.0;NATIONAL DRUG FILE;**401**; 30 Oct 98;Build 89
+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
+10 KILL ^TMP($JOB),^TMP("PSN",$JOB),^TMP("PSNN",$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 IF FLDS[","
Begin DoDot:2
+30 ;it should, but
+31 SET LI=$PIECE(DIA,"^",3)
FOR J=1:1:$LENGTH(LI,",")-1
SET ROOT=+$PIECE(^DD(ROOT,+$PIECE(LI,",",J),0),"^",2)
+32 SET LI=$PIECE(DIA,"^")
SET IENS=""
FOR J=$LENGTH(LI,","):-1:1
SET IENS=IENS_$PIECE(LI,",",J)_","
+33 SET DA=+IENS
End DoDot:2
+34 ;I $$GET1^DIQ(ROOT,IENS,.01)]"" S FDA(ROOT,IENS,.01)=NEW D FILE^DIE("","FDA") Q
+35 SET FDA(ROOT,"+"_IENS,.01)=NEW
SET IEN(DA)=DA
DO UPDATE^DIE("","FDA","IEN")
+36 SET TREC=TREC+1
IF '(TREC#500)
DO UPDATE^XPDID(TREC)
+37 IF FILE=50.68
IF $PIECE(DIA,"^",3)="14,.01"
SET ^TMP("PSNN",$JOB,$PIECE(DIA,"^"))=""
End DoDot:1
+38 ;
+39 SET FILE=0
SET GROOT=$NAME(@XPDGREF@("DATAO"))
+40 ;now load the rest of the data
+41 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
+42 SET IENS=$PIECE(DIA,"^")_","
SET FLDS=$PIECE(DIA,"^",3)
SET ROOT=FILE
KILL FDA,IEN
+43 IF FLDS[","
Begin DoDot:2
+44 SET LI=$PIECE(DIA,"^",3)
FOR J=1:1:$LENGTH(LI,",")-1
SET ROOT=+$PIECE(^DD(ROOT,+$PIECE(LI,",",J),0),"^",2)
+45 SET LI=$PIECE(DIA,"^")
SET IENS=""
FOR J=$LENGTH(LI,","):-1:1
SET IENS=IENS_$PIECE(LI,",",J)_","
+46 SET FLDS=$PIECE(FLDS,",",$LENGTH(FLDS,","))
End DoDot:2
+47 SET FDA(ROOT,IENS,FLDS)=NEW
DO FILE^DIE("","FDA")
+48 SET TREC=TREC+1
IF '(TREC#500)
DO UPDATE^XPDID(TREC)
End DoDot:1
+49 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
+50 ;
+51 ;
WORD SET ROOT1=$NAME(@XPDGREF@("WORD"))
SET CT=0
SET ROOT2=$NAME(@ROOT1@(0))
+1 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
+2 ;
+3 ;
MESSAGE KILL ^TMP($JOB)
MERGE ^TMP($JOB)=@XPDGREF@("MESSAGE")
KILL ^TMP($JOB,0)
+1 ;
GROUP KILL XMY
SET X=$GET(@XPDGREF@("GROUP"))
IF X]""
SET XMY("G."_X_"@"_^XMB("NETNAME"))=""
+1 SET DA=0
FOR
SET DA=$ORDER(^XUSEC("PSNMGR",DA))
if 'DA
QUIT
SET XMY(DA)=""
+2 IF $DATA(DUZ)
SET XMY(DUZ)=""
+3 ;
+4 SET XMSUB="DATA UPDATE FOR NDF"
+5 SET XMDUZ="NDF MANAGER"
+6 SET XMTEXT="^TMP($J,"
NEW DIFROM
DO ^XMD
+7 ;
+8 KILL ^TMP($JOB)
MERGE ^TMP($JOB)=@XPDGREF@("MESSAGE2")
KILL ^TMP($JOB,0)
+9 ;
+10 KILL XMY
SET X=$GET(@XPDGREF@("GROUP"))
IF X]""
SET XMY("G."_X_"@"_^XMB("NETNAME"))=""
+11 SET DA=0
FOR
SET DA=$ORDER(^XUSEC("PSNMGR",DA))
if 'DA
QUIT
SET XMY(DA)=""
+12 IF $DATA(DUZ)
SET XMY(DUZ)=""
+13 ;
+14 SET XMSUB="UPDATED INTERACTIONS"
+15 SET XMDUZ="NDF MANAGER"
+16 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(@ROOT1@(GE))!$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
