- PSN500D ;BIR/DMA-post install routine to load data ; 01 Nov 2016 3:50 PM
- ;;4.0;NATIONAL DRUG FILE;**500**; 30 Oct 98;Build 118
- ;
- ; 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
- N PSNCPCNT
- 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&(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 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[HPSN500D 9826 printed Dec 13, 2024@02:22:22 Page 2
- PSN500D ;BIR/DMA-post install routine to load data ; 01 Nov 2016 3:50 PM
- +1 ;;4.0;NATIONAL DRUG FILE;**500**; 30 Oct 98;Build 118
- +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 NEW PSNCPCNT
- +28 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
- +29 SET IENS=$PIECE(DIA,"^")_","
- SET FLDS=$PIECE(DIA,"^",3)
- SET ROOT=FILE
- KILL FDA,IEN
- +30 ; *** Removing old COPAY TIER
- +31 IF FILE=50.68&(FLDS="45,.01")&(IENS[",1")
- IF $DATA(^PSNDF(50.68,+DIA,10,0))
- SET PSNCPCNT=0
- Begin DoDot:2
- +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:2
- +33 ; ***
- +34 IF FLDS[","
- Begin DoDot:2
- +35 ;it should, but
- +36 SET LI=$PIECE(DIA,"^",3)
- FOR J=1:1:$LENGTH(LI,",")-1
- SET ROOT=+$PIECE(^DD(ROOT,+$PIECE(LI,",",J),0),"^",2)
- +37 SET LI=$PIECE(DIA,"^")
- SET IENS=""
- FOR J=$LENGTH(LI,","):-1:1
- SET IENS=IENS_$PIECE(LI,",",J)_","
- +38 SET DA=+IENS
- End DoDot:2
- +39 ;I $$GET1^DIQ(ROOT,IENS,.01)]"" S FDA(ROOT,IENS,.01)=NEW D FILE^DIE("","FDA") Q
- +40 SET FDA(ROOT,"+"_IENS,.01)=NEW
- SET IEN(DA)=DA
- DO UPDATE^DIE("","FDA","IEN")
- +41 SET TREC=TREC+1
- IF '(TREC#500)
- DO UPDATE^XPDID(TREC)
- +42 IF FILE=50.68
- IF $PIECE(DIA,"^",3)="14,.01"
- SET ^TMP("PSNN",$JOB,$PIECE(DIA,"^"))=""
- End DoDot:1
- +43 ;
- +44 SET FILE=0
- SET GROOT=$NAME(@XPDGREF@("DATAO"))
- +45 ;now load the rest of the data
- +46 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
- +47 SET IENS=$PIECE(DIA,"^")_","
- SET FLDS=$PIECE(DIA,"^",3)
- SET ROOT=FILE
- KILL FDA,IEN
- +48 IF FLDS[","
- Begin DoDot:2
- +49 SET LI=$PIECE(DIA,"^",3)
- FOR J=1:1:$LENGTH(LI,",")-1
- SET ROOT=+$PIECE(^DD(ROOT,+$PIECE(LI,",",J),0),"^",2)
- +50 SET LI=$PIECE(DIA,"^")
- SET IENS=""
- FOR J=$LENGTH(LI,","):-1:1
- SET IENS=IENS_$PIECE(LI,",",J)_","
- +51 SET FLDS=$PIECE(FLDS,",",$LENGTH(FLDS,","))
- End DoDot:2
- +52 SET FDA(ROOT,IENS,FLDS)=NEW
- DO FILE^DIE("","FDA")
- +53 SET TREC=TREC+1
- IF '(TREC#500)
- DO UPDATE^XPDID(TREC)
- End DoDot:1
- +54 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
- +55 ;
- +56 ;
- 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