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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNXREF 5103 printed Dec 13, 2024@02:25:14 Page 2
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 ;
