source: WorldVistAEHR/trunk/r/NATIONAL_DRUG_FILE-PSN/PSNXREF.m@ 1150

Last change on this file since 1150 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.9 KB
RevLine 
[613]1PSNXREF ;BIR/DMA-Cross references ;04 Dec 98 / 10:44 AM
2 ;;4.0; NATIONAL DRUG FILE;**3,54,78**; 30 Oct 98
3 ;
4ING ;From active ingredients in VA product file - set drug ingredient multiple
5 N PSNDATA,PSNARG
6 S PSNDATA=$P(^PSNDF(50.68,DA(1),0),"^",2)_"A"_DA(1) Q:'$P(PSNDATA,"A")
7 I '$D(^PS(50.416,DA,1,"B",PSNDATA)) S PSNARG=$O(^PS(50.416,DA,1," "),-1)+1,^(PSNARG,0)=PSNDATA,^PS(50.416,DA,1,"B",PSNDATA,PSNARG)=""
8 S PSNARG=$P(^PS(50.416,DA,0),"^",2),PSNARG=$S(PSNARG:PSNARG,1:DA),^PS(50.416,"APD",PSNDATA,PSNARG)=""
9 ;
10INGINT ;now the interactions - get primary - check Xref in 56 - loop thru
11 ;APS in 50.416
12 N J,PSNAR,PSN0,PSN1,PSN2,PSN3,PSNC,PSNDA,PSNINT,PSND1
13 S J=$P(^PS(50.416,DA,0),"^",2),PSNDA=$S(J:J,1:DA)
14 K PSN2 S PSN2=0,PSNC=0 F S PSN2=$O(^PS(56,"AE",PSNDA,PSN2)) Q:'PSN2 K PSNAR S PSNAR(PSN2)="",PSNINT=0 F S PSNINT=$O(^PS(56,"AE",PSNDA,PSN2,PSNINT)) Q:'PSNINT D
15 .S PSN0=0 F S PSN0=$O(^PS(50.416,"APS",PSN2,PSN0)) Q:'PSN0 S PSNAR(PSN0)=""
16 .S PSN0=0 F S PSN0=$O(PSNAR(PSN0)),PSN1=0 Q:'PSN0 F S PSN1=$O(^PS(50.416,PSN0,1,PSN1)) Q:'PSN1 S PSND1=$P(^(PSN1,0),"^"),^PS(56,"APD",PSNDATA,PSND1,PSNINT)="",^PS(56,"APD",PSND1,PSNDATA,PSNINT)="",PSNC=PSNC+2
17 .I PSNC S $P(^(0),"^",6)=$P(^PS(56,PSNINT,0),"^",6)+PSNC
18 Q
19 ;
20KING ;from active ingredient - kill drug identifier multiple
21 S PSNDATA=$P(^PSNDF(50.68,DA(1),0),"^",2)_"A"_DA(1)
22 S PSNARG=$O(^PS(50.416,DA,1,"B",PSNDATA,0)) I PSNARG K ^PS(50.416,DA,1,PSNARG),^PS(50.416,DA,1,"B",PSNDATA)
23 S PSNARG=$P(^PS(50.416,DA,0),"^",2),PSNARG=$S(PSNARG:PSNARG,1:DA) K ^PS(50.416,"APD",PSNDATA,PSNARG)
24 ;GET RID OF ALL INTERACTIONS FOR THIS COMBO
25 S PSNB="^PS(56,""APD"","""_PSNDATA_""")"
26 F S PSNB=$Q(@PSNB) Q:$QS(PSNB,3)'=PSNDATA S PSNC=^PS(56,$QS(PSNB,5),0) I $P(PSNC,"^",2)=PSNARG!($P(PSNC,"^",3)=PSNARG) D
27 .K @PSNB S PSND=$P(PSNB,",",1,2)_","_$P(PSNB,",",4)_","_$P(PSNB,",",3)_","_$P(PSNB,",",5) K @PSND
28 Q
29 ;
30INT ;INTERACTIONS
31 N PSN,PSN1,PSN2,PSN3,PSNA,PSNB,PSNC
32 S PSN1=$P(^PS(56,DA,0),"^",2),PSN2=$P(^(0),"^",3) Q:PSN1="" Q:PSN2="" S PSN1(PSN1)="",PSN2(PSN2)=""
33 S PSN=0 F S PSN=$O(^PS(50.416,"APS",PSN1,PSN)) Q:'PSN S PSN1(PSN)=""
34 S PSN=0 F S PSN=$O(^PS(50.416,"APS",PSN2,PSN)) Q:'PSN S PSN2(PSN)=""
35 S PSN1=0,PSN2=0,PSNC=0 F S PSN1=$O(PSN1(PSN1)) Q:'PSN1 F S PSN2=$O(PSN2(PSN2)) Q:'PSN2 D
36 .S PSN3=0,PSN4=0 F S PSN3=$O(^PS(50.416,PSN1,1,PSN3)),PSN4=0 Q:'PSN3 S PSNA=^(PSN3,0) F S PSN4=$O(^PS(50.416,PSN2,1,PSN4)) Q:'PSN4 S PSNB=^(PSN4,0) S ^PS(56,"APD",PSNA,PSNB,DA)="",^PS(56,"APD",PSNB,PSNA,DA)="",PSNC=PSNC+2
37 S $P(^PS(56,DA,0),"^",6)=PSNC
38 Q
39 ;
40KINT ;DELETE INTERACTIONS
41 N PSN,PSN1,PSN2,PSN3,PSN4,PSNA,PSNB
42 S PSN1=$P(^PS(56,DA,0),"^",2),PSN2=$P(^(0),"^",3),PSN1(PSN1)="",PSN2(PSN2)=""
43 S PSN=0 F S PSN=$O(^PS(50.416,"APS",PSN1,PSN)) Q:'PSN S PSN1(PSN)=""
44 S PSN=0 F S PSN=$O(^PS(50.416,"APS",PSN2,PSN)) Q:'PSN S PSN2(PSN)=""
45 S PSN1=0,PSN2=0 F S PSN1=$O(PSN1(PSN1)) Q:'PSN1 F S PSN2=$O(PSN2(PSN2)) Q:'PSN2 D
46 .S PSN3=0,PSN4=0 F S PSN3=$O(^PS(50.416,PSN1,1,PSN3)) Q:'PSN3 S PSNA=^(PSN3,0) F S PSN4=$O(^PS(50.416,PSN2,1,PSN4)) Q:'PSN4 S PSNB=^(PSN4,0) K ^PS(56,"APD",PSNA,PSNB,DA),^PS(56,"APD",PSNB,PSNA,DA)
47 Q
48 ;
49GENER ;INACTIVE PRODUCTS WHEN GENERIC IS INACTIVATED
50 N DA1,DA2 S DA1=0 F S DA1=$O(^PSNDF(50.6,"APRO",DA,DA1)) Q:'DA1 S $P(^PSNDF(50.68,DA1,7),"^",3)=X S DA2=0 F S DA2=$O(^PSNDF(50.68,"ANDC",DA1,DA2)) Q:'DA2 S $P(^PSNDF(50.67,DA2,0),"^",7)=X
51 Q
52 ;
53KGENER ;REACTIVATE PRODUCTS WHEN GENERIC IS MADE ACTIVE
54 N DA1,DA2 S DA1=0 F S DA1=$O(^PSNDF(50.6,"APRO",DA,DA1)) Q:'DA1 S $P(^PSNDF(50.68,DA1,7),"^",3)="" S DA2=0 F S DA2=$O(^PSNDF(50.68,"ANDC",DA1,DA2)) Q:'DA2 S $P(^PSNDF(50.67,DA2,0),"^",7)=""
55 Q
56 ;
57PROD ;INACTIVATE NDCS WHEN PRODUCTS ARE INACTIVE
58 N DA2 S DA2=0 F S DA2=$O(^PSNDF(50.68,"ANDC",DA,DA2)) Q:'DA2 S $P(^PSNDF(50.67,DA2,0),"^",7)=X
59 Q
60 ;
61KPROD ;REACTIVATE NDCS WHEN PRODUCTS ARE MADE ACTIVE
62 N DA2 S DA2=0 F S DA2=$O(^PSNDF(50.68,"ANDC",DA,DA2)) Q:'DA2 S $P(^PSNDF(50.67,DA,0),"^",7)=""
63 Q
64 ;
65ING2 ;from VA generic name in file 50.68
66 N PSNDATA,PSNK,PSNO,PSN1,PSN2,PSN3,PSNINT
67 S PSNDATA=X_"A"_DA,PSNK=0 F S PSNK=$O(^PSNDF(50.68,DA,2,PSNK)) Q:'PSNK S ENT=$O(^PS(50.416,PSNK,1," "),-1)+1,^(ENT,0)=PSNDATA,^PS(50.416,PSNK,1,"B",PSNDATA,ENT)="" D
68 .;
69 .;and the interactions
70 .S PSNO=^PS(50.416,PSNK,0),PSN1=$S($P(PSNO,"^",2):$P(PSNO,"^",2),1:PSNK) Q:'$D(^PS(56,"AE",PSN1))
71 .S PSN2=0 F S PSN2=$O(^PS(56,"AE",PSN1,PSN2)) Q:'PSN2 S PSNINT=$O(^(PSN2,0)) D
72 ..S PSN0=0 F J=0:1 S PSN0=$O(^PS(50.416,"APS",PSN2,PSN0)) Q:'PSN0 S PSN3=0 F S PSN3=$O(^PS(50.416,PSN0,1,PSN3)) Q:'PSN3 S PSND1=$P(^(PSN3,0),"^"),^PS(56,"APD",PSNDATA,PSND1,PSNINT)="",^PS(56,"APD",PSND1,PSNDATA,PSNINT)=""
73 ..S $P(^(0),"^",6)=$P(^PS(56,PSNINT,0),"^",6)+J
74 Q
75 ;
76KING2 ;from VA generic name in file 50.68
77 N PSNDATA,PSNARG,PSNJ,PSNK
78 S PSNDATA=X_"^"_DA,PSNK=0
79 F S PSNK=$O(^PSNDF(50.68,2,PSNK)) Q:'PSNK D
80 .S PSNJ=$O(^PS(50.416,PSNK,1,"B",PSNDATA,0)) I PSNJ K ^(PSNJ),^PS(50.416,PSNK,1,PSNJ)
81 .S PSNO="" F S PSNO=$O(^PS(56,"APD",PSNDATA,PSNO)) Q:PSNO="" K ^(PSNO),^PS(56,"APD",PSNO,PSNDATA)
82 Q
83 ;
Note: See TracBrowser for help on using the repository browser.