- PSNXREF ;BIR/DMA-Cross references ;04 Dec 98 / 10:44 AM
- ;;4.0; NATIONAL DRUG FILE;**3,54,78**; 30 Oct 98
- ;
- ING ;From active ingredients in VA product file - set drug ingredient multiple
- N PSNDATA,PSNARG
- S PSNDATA=$P(^PSNDF(50.68,DA(1),0),"^",2)_"A"_DA(1) Q:'$P(PSNDATA,"A")
- 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)=""
- S PSNARG=$P(^PS(50.416,DA,0),"^",2),PSNARG=$S(PSNARG:PSNARG,1:DA),^PS(50.416,"APD",PSNDATA,PSNARG)=""
- ;
- INGINT ;now the interactions - get primary - check Xref in 56 - loop thru
- ;APS in 50.416
- N J,PSNAR,PSN0,PSN1,PSN2,PSN3,PSNC,PSNDA,PSNINT,PSND1
- S J=$P(^PS(50.416,DA,0),"^",2),PSNDA=$S(J:J,1:DA)
- 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
- .S PSN0=0 F S PSN0=$O(^PS(50.416,"APS",PSN2,PSN0)) Q:'PSN0 S PSNAR(PSN0)=""
- .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
- .I PSNC S $P(^(0),"^",6)=$P(^PS(56,PSNINT,0),"^",6)+PSNC
- Q
- ;
- KING ;from active ingredient - kill drug identifier multiple
- S PSNDATA=$P(^PSNDF(50.68,DA(1),0),"^",2)_"A"_DA(1)
- 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)
- S PSNARG=$P(^PS(50.416,DA,0),"^",2),PSNARG=$S(PSNARG:PSNARG,1:DA) K ^PS(50.416,"APD",PSNDATA,PSNARG)
- ;GET RID OF ALL INTERACTIONS FOR THIS COMBO
- S PSNB="^PS(56,""APD"","""_PSNDATA_""")"
- 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
- .K @PSNB S PSND=$P(PSNB,",",1,2)_","_$P(PSNB,",",4)_","_$P(PSNB,",",3)_","_$P(PSNB,",",5) K @PSND
- Q
- ;
- INT ;INTERACTIONS
- N PSN,PSN1,PSN2,PSN3,PSNA,PSNB,PSNC
- S PSN1=$P(^PS(56,DA,0),"^",2),PSN2=$P(^(0),"^",3) Q:PSN1="" Q:PSN2="" S PSN1(PSN1)="",PSN2(PSN2)=""
- S PSN=0 F S PSN=$O(^PS(50.416,"APS",PSN1,PSN)) Q:'PSN S PSN1(PSN)=""
- S PSN=0 F S PSN=$O(^PS(50.416,"APS",PSN2,PSN)) Q:'PSN S PSN2(PSN)=""
- S PSN1=0,PSN2=0,PSNC=0 F S PSN1=$O(PSN1(PSN1)) Q:'PSN1 F S PSN2=$O(PSN2(PSN2)) Q:'PSN2 D
- .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
- S $P(^PS(56,DA,0),"^",6)=PSNC
- Q
- ;
- KINT ;DELETE INTERACTIONS
- N PSN,PSN1,PSN2,PSN3,PSN4,PSNA,PSNB
- S PSN1=$P(^PS(56,DA,0),"^",2),PSN2=$P(^(0),"^",3),PSN1(PSN1)="",PSN2(PSN2)=""
- S PSN=0 F S PSN=$O(^PS(50.416,"APS",PSN1,PSN)) Q:'PSN S PSN1(PSN)=""
- S PSN=0 F S PSN=$O(^PS(50.416,"APS",PSN2,PSN)) Q:'PSN S PSN2(PSN)=""
- S PSN1=0,PSN2=0 F S PSN1=$O(PSN1(PSN1)) Q:'PSN1 F S PSN2=$O(PSN2(PSN2)) Q:'PSN2 D
- .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)
- Q
- ;
- GENER ;INACTIVE PRODUCTS WHEN GENERIC IS INACTIVATED
- 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
- Q
- ;
- KGENER ;REACTIVATE PRODUCTS WHEN GENERIC IS MADE ACTIVE
- 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)=""
- Q
- ;
- PROD ;INACTIVATE NDCS WHEN PRODUCTS ARE INACTIVE
- 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
- Q
- ;
- KPROD ;REACTIVATE NDCS WHEN PRODUCTS ARE MADE ACTIVE
- 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)=""
- Q
- ;
- ING2 ;from VA generic name in file 50.68
- N PSNDATA,PSNK,PSNO,PSN1,PSN2,PSN3,PSNINT
- 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
- .;
- .;and the interactions
- .S PSNO=^PS(50.416,PSNK,0),PSN1=$S($P(PSNO,"^",2):$P(PSNO,"^",2),1:PSNK) Q:'$D(^PS(56,"AE",PSN1))
- .S PSN2=0 F S PSN2=$O(^PS(56,"AE",PSN1,PSN2)) Q:'PSN2 S PSNINT=$O(^(PSN2,0)) D
- ..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)=""
- ..S $P(^(0),"^",6)=$P(^PS(56,PSNINT,0),"^",6)+J
- Q
- ;
- KING2 ;from VA generic name in file 50.68
- N PSNDATA,PSNARG,PSNJ,PSNK
- S PSNDATA=X_"^"_DA,PSNK=0
- F S PSNK=$O(^PSNDF(50.68,2,PSNK)) Q:'PSNK D
- .S PSNJ=$O(^PS(50.416,PSNK,1,"B",PSNDATA,0)) I PSNJ K ^(PSNJ),^PS(50.416,PSNK,1,PSNJ)
- .S PSNO="" F S PSNO=$O(^PS(56,"APD",PSNDATA,PSNO)) Q:PSNO="" K ^(PSNO),^PS(56,"APD",PSNO,PSNDATA)
- Q
- ;
- PSNXREF ;BIR/DMA-Cross references ;04 Dec 98 / 10:44 AM
- +1 ;;4.0; NATIONAL DRUG FILE;**3,54,78**; 30 Oct 98
- +2 ;
- ING ;From active ingredients in VA product file - set drug ingredient multiple
- +1 NEW PSNDATA,PSNARG
- +2 SET PSNDATA=$PIECE(^PSNDF(50.68,DA(1),0),"^",2)_"A"_DA(1)
- IF '$PIECE(PSNDATA,"A")
- QUIT
- +3 IF '$DATA(^PS(50.416,DA,1,"B",PSNDATA))
- SET PSNARG=$ORDER(^PS(50.416,DA,1," "),-1)+1
- SET ^(PSNARG,0)=PSNDATA
- SET ^PS(50.416,DA,1,"B",PSNDATA,PSNARG)=""
- +4 SET PSNARG=$PIECE(^PS(50.416,DA,0),"^",2)
- SET PSNARG=$SELECT(PSNARG:PSNARG,1:DA)
- SET ^PS(50.416,"APD",PSNDATA,PSNARG)=""
- +5 ;
- INGINT ;now the interactions - get primary - check Xref in 56 - loop thru
- +1 ;APS in 50.416
- +2 NEW J,PSNAR,PSN0,PSN1,PSN2,PSN3,PSNC,PSNDA,PSNINT,PSND1
- +3 SET J=$PIECE(^PS(50.416,DA,0),"^",2)
- SET PSNDA=$SELECT(J:J,1:DA)
- +4 KILL PSN2
- SET PSN2=0
- SET PSNC=0
- FOR
- SET PSN2=$ORDER(^PS(56,"AE",PSNDA,PSN2))
- IF 'PSN2
- QUIT
- KILL PSNAR
- SET PSNAR(PSN2)=""
- SET PSNINT=0
- FOR
- SET PSNINT=$ORDER(^PS(56,"AE",PSNDA,PSN2,PSNINT))
- IF 'PSNINT
- QUIT
- Begin DoDot:1
- +5 SET PSN0=0
- FOR
- SET PSN0=$ORDER(^PS(50.416,"APS",PSN2,PSN0))
- IF 'PSN0
- QUIT
- SET PSNAR(PSN0)=""
- +6 SET PSN0=0
- FOR
- SET PSN0=$ORDER(PSNAR(PSN0))
- SET PSN1=0
- IF 'PSN0
- QUIT
- FOR
- SET PSN1=$ORDER(^PS(50.416,PSN0,1,PSN1))
- IF 'PSN1
- QUIT
- SET PSND1=$PIECE(^(PSN1,0),"^")
- SET ^PS(56,"APD",PSNDATA,PSND1,PSNINT)=""
- SET ^PS(56,"APD",PSND1,PSNDATA,PSNINT)=""
- SET PSNC=PSNC+2
- +7 IF PSNC
- SET $PIECE(^(0),"^",6)=$PIECE(^PS(56,PSNINT,0),"^",6)+PSNC
- End DoDot:1
- +8 QUIT
- +9 ;
- KING ;from active ingredient - kill drug identifier multiple
- +1 SET PSNDATA=$PIECE(^PSNDF(50.68,DA(1),0),"^",2)_"A"_DA(1)
- +2 SET PSNARG=$ORDER(^PS(50.416,DA,1,"B",PSNDATA,0))
- IF PSNARG
- KILL ^PS(50.416,DA,1,PSNARG),^PS(50.416,DA,1,"B",PSNDATA)
- +3 SET PSNARG=$PIECE(^PS(50.416,DA,0),"^",2)
- SET PSNARG=$SELECT(PSNARG:PSNARG,1:DA)
- KILL ^PS(50.416,"APD",PSNDATA,PSNARG)
- +4 ;GET RID OF ALL INTERACTIONS FOR THIS COMBO
- +5 SET PSNB="^PS(56,""APD"","""_PSNDATA_""")"
- +6 FOR
- SET PSNB=$QUERY(@PSNB)
- IF $QSUBSCRIPT(PSNB,3)'=PSNDATA
- QUIT
- SET PSNC=^PS(56,$QSUBSCRIPT(PSNB,5),0)
- IF $PIECE(PSNC,"^",2)=PSNARG!($PIECE(PSNC,"^",3)=PSNARG)
- Begin DoDot:1
- +7 KILL @PSNB
- SET PSND=$PIECE(PSNB,",",1,2)_","_$PIECE(PSNB,",",4)_","_$PIECE(PSNB,",",3)_","_$PIECE(PSNB,",",5)
- KILL @PSND
- End DoDot:1
- +8 QUIT
- +9 ;
- INT ;INTERACTIONS
- +1 NEW PSN,PSN1,PSN2,PSN3,PSNA,PSNB,PSNC
- +2 SET PSN1=$PIECE(^PS(56,DA,0),"^",2)
- SET PSN2=$PIECE(^(0),"^",3)
- IF PSN1=""
- QUIT
- IF PSN2=""
- QUIT
- SET PSN1(PSN1)=""
- SET PSN2(PSN2)=""
- +3 SET PSN=0
- FOR
- SET PSN=$ORDER(^PS(50.416,"APS",PSN1,PSN))
- IF 'PSN
- QUIT
- SET PSN1(PSN)=""
- +4 SET PSN=0
- FOR
- SET PSN=$ORDER(^PS(50.416,"APS",PSN2,PSN))
- IF 'PSN
- QUIT
- SET PSN2(PSN)=""
- +5 SET PSN1=0
- SET PSN2=0
- SET PSNC=0
- FOR
- SET PSN1=$ORDER(PSN1(PSN1))
- IF 'PSN1
- QUIT
- FOR
- SET PSN2=$ORDER(PSN2(PSN2))
- IF 'PSN2
- QUIT
- Begin DoDot:1
- +6 SET PSN3=0
- SET PSN4=0
- FOR
- SET PSN3=$ORDER(^PS(50.416,PSN1,1,PSN3))
- SET PSN4=0
- IF 'PSN3
- QUIT
- SET PSNA=^(PSN3,0)
- FOR
- SET PSN4=$ORDER(^PS(50.416,PSN2,1,PSN4))
- IF 'PSN4
- QUIT
- SET PSNB=^(PSN4,0)
- SET ^PS(56,"APD",PSNA,PSNB,DA)=""
- SET ^PS(56,"APD",PSNB,PSNA,DA)=""
- SET PSNC=PSNC+2
- End DoDot:1
- +7 SET $PIECE(^PS(56,DA,0),"^",6)=PSNC
- +8 QUIT
- +9 ;
- KINT ;DELETE INTERACTIONS
- +1 NEW PSN,PSN1,PSN2,PSN3,PSN4,PSNA,PSNB
- +2 SET PSN1=$PIECE(^PS(56,DA,0),"^",2)
- SET PSN2=$PIECE(^(0),"^",3)
- SET PSN1(PSN1)=""
- SET PSN2(PSN2)=""
- +3 SET PSN=0
- FOR
- SET PSN=$ORDER(^PS(50.416,"APS",PSN1,PSN))
- IF 'PSN
- QUIT
- SET PSN1(PSN)=""
- +4 SET PSN=0
- FOR
- SET PSN=$ORDER(^PS(50.416,"APS",PSN2,PSN))
- IF 'PSN
- QUIT
- SET PSN2(PSN)=""
- +5 SET PSN1=0
- SET PSN2=0
- FOR
- SET PSN1=$ORDER(PSN1(PSN1))
- IF 'PSN1
- QUIT
- FOR
- SET PSN2=$ORDER(PSN2(PSN2))
- IF 'PSN2
- QUIT
- Begin DoDot:1
- +6 SET PSN3=0
- SET PSN4=0
- FOR
- SET PSN3=$ORDER(^PS(50.416,PSN1,1,PSN3))
- IF 'PSN3
- QUIT
- SET PSNA=^(PSN3,0)
- FOR
- SET PSN4=$ORDER(^PS(50.416,PSN2,1,PSN4))
- IF 'PSN4
- QUIT
- SET PSNB=^(PSN4,0)
- KILL ^PS(56,"APD",PSNA,PSNB,DA),^PS(56,"APD",PSNB,PSNA,DA)
- End DoDot:1
- +7 QUIT
- +8 ;
- GENER ;INACTIVE PRODUCTS WHEN GENERIC IS INACTIVATED
- +1 NEW DA1,DA2
- SET DA1=0
- FOR
- SET DA1=$ORDER(^PSNDF(50.6,"APRO",DA,DA1))
- IF 'DA1
- QUIT
- SET $PIECE(^PSNDF(50.68,DA1,7),"^",3)=X
- SET DA2=0
- FOR
- SET DA2=$ORDER(^PSNDF(50.68,"ANDC",DA1,DA2))
- IF 'DA2
- QUIT
- SET $PIECE(^PSNDF(50.67,DA2,0),"^",7)=X
- +2 QUIT
- +3 ;
- KGENER ;REACTIVATE PRODUCTS WHEN GENERIC IS MADE ACTIVE
- +1 NEW DA1,DA2
- SET DA1=0
- FOR
- SET DA1=$ORDER(^PSNDF(50.6,"APRO",DA,DA1))
- IF 'DA1
- QUIT
- SET $PIECE(^PSNDF(50.68,DA1,7),"^",3)=""
- SET DA2=0
- FOR
- SET DA2=$ORDER(^PSNDF(50.68,"ANDC",DA1,DA2))
- IF 'DA2
- QUIT
- SET $PIECE(^PSNDF(50.67,DA2,0),"^",7)=""
- +2 QUIT
- +3 ;
- PROD ;INACTIVATE NDCS WHEN PRODUCTS ARE INACTIVE
- +1 NEW DA2
- SET DA2=0
- FOR
- SET DA2=$ORDER(^PSNDF(50.68,"ANDC",DA,DA2))
- IF 'DA2
- QUIT
- SET $PIECE(^PSNDF(50.67,DA2,0),"^",7)=X
- +2 QUIT
- +3 ;
- KPROD ;REACTIVATE NDCS WHEN PRODUCTS ARE MADE ACTIVE
- +1 NEW DA2
- SET DA2=0
- FOR
- SET DA2=$ORDER(^PSNDF(50.68,"ANDC",DA,DA2))
- IF 'DA2
- QUIT
- SET $PIECE(^PSNDF(50.67,DA,0),"^",7)=""
- +2 QUIT
- +3 ;
- ING2 ;from VA generic name in file 50.68
- +1 NEW PSNDATA,PSNK,PSNO,PSN1,PSN2,PSN3,PSNINT
- +2 SET PSNDATA=X_"A"_DA
- SET PSNK=0
- FOR
- SET PSNK=$ORDER(^PSNDF(50.68,DA,2,PSNK))
- IF 'PSNK
- QUIT
- SET ENT=$ORDER(^PS(50.416,PSNK,1," "),-1)+1
- SET ^(ENT,0)=PSNDATA
- SET ^PS(50.416,PSNK,1,"B",PSNDATA,ENT)=""
- Begin DoDot:1
- +3 ;
- +4 ;and the interactions
- +5 SET PSNO=^PS(50.416,PSNK,0)
- SET PSN1=$SELECT($PIECE(PSNO,"^",2):$PIECE(PSNO,"^",2),1:PSNK)
- IF '$DATA(^PS(56,"AE",PSN1))
- QUIT
- +6 SET PSN2=0
- FOR
- SET PSN2=$ORDER(^PS(56,"AE",PSN1,PSN2))
- IF 'PSN2
- QUIT
- SET PSNINT=$ORDER(^(PSN2,0))
- Begin DoDot:2
- +7 SET PSN0=0
- FOR J=0:1
- SET PSN0=$ORDER(^PS(50.416,"APS",PSN2,PSN0))
- IF 'PSN0
- QUIT
- SET PSN3=0
- FOR
- SET PSN3=$ORDER(^PS(50.416,PSN0,1,PSN3))
- IF 'PSN3
- QUIT
- SET PSND1=$PIECE(^(PSN3,0),"^")
- SET ^PS(56,"APD",PSNDATA,PSND1,PSNINT)=""
- SET ^PS(56,"APD",PSND1,PSNDATA,PSNINT)=""
- +8 SET $PIECE(^(0),"^",6)=$PIECE(^PS(56,PSNINT,0),"^",6)+J
- End DoDot:2
- End DoDot:1
- +9 QUIT
- +10 ;
- KING2 ;from VA generic name in file 50.68
- +1 NEW PSNDATA,PSNARG,PSNJ,PSNK
- +2 SET PSNDATA=X_"^"_DA
- SET PSNK=0
- +3 FOR
- SET PSNK=$ORDER(^PSNDF(50.68,2,PSNK))
- IF 'PSNK
- QUIT
- Begin DoDot:1
- +4 SET PSNJ=$ORDER(^PS(50.416,PSNK,1,"B",PSNDATA,0))
- IF PSNJ
- KILL ^(PSNJ),^PS(50.416,PSNK,1,PSNJ)
- +5 SET PSNO=""
- FOR
- SET PSNO=$ORDER(^PS(56,"APD",PSNDATA,PSNO))
- IF PSNO=""
- QUIT
- KILL ^(PSNO),^PS(56,"APD",PSNO,PSNDATA)
- End DoDot:1
- +6 QUIT
- +7 ;
