- PSNDDI1 ;BIR/SAB-BUILDS XREF IN DRUG INTERACTION FILE ;01/12/98 5:18
- ;;4.0; NATIONAL DRUG FILE;; 30 Oct 98
- BEGIN D XREF,EX
- Q
- XREF ;code to create 'APD' xref on Drug Interaction file (#56)
- ;I '$D(ZTSK),'$D(PSMSG) D WAIT^DICD W "Building 'APD' X-Ref."
- S ID1=$P(^PS(56,DA,0),"^",2),ID2=$P(^(0),"^",3),TOT=0
- F I1=0:0 S I1=$O(^PS(50.416,ID1,1,I1)) Q:'I1 S R2=$P(^(I1,0),"^") F I2=0:0 S I2=$O(^PS(50.416,ID2,1,I2)) Q:'I2 S D2=$P(^(I2,0),"^") W:+$G(PSMSG) "." D SEC
- F I1=0:0 S I1=$O(^PS(50.416,"APS",ID1,I1)) Q:'I1 F I3=0:0 S I3=$O(^PS(50.416,I1,1,I3)) Q:'I3 S R2=$P(^(I3,0),"^") F I5=0:0 S I5=$O(^PS(50.416,"APS",ID2,I5)) Q:'I5 F I6=0:0 S I6=$O(^PS(50.416,I5,1,I6)) Q:'I6 S D2=$P(^(I6,0),"^") D SEC
- F I1=0:0 S I1=$O(^PS(50.416,ID1,1,I1)) Q:'I1 S R2=$P(^(I1,0),"^") F I5=0:0 S I5=$O(^PS(50.416,"APS",ID2,I5)) Q:'I5 F I6=0:0 S I6=$O(^PS(50.416,I5,1,I6)) Q:'I6 S D2=$P(^(I6,0),"^") D SEC
- F I2=0:0 S I2=$O(^PS(50.416,ID2,1,I2)) Q:'I2 S D2=$P(^(I2,0),"^") F I1=0:0 S I1=$O(^PS(50.416,"APS",ID1,I1)) Q:'I1 F I3=0:0 S I3=$O(^PS(50.416,I1,1,I3)) Q:'I3 S R2=$P(^(I3,0),"^") D SEC
- S $P(^PS(56,DA,0),"^",6)=TOT
- EX K TOT,I5,I6,D2,I3,I1,I2,R2,ID2,ID1
- Q
- SEC I +$G(DEL) K ^PS(56,"APD",R2,D2,DA),^PS(56,"APD",D2,R2,DA) Q
- S ^PS(56,"APD",R2,D2,DA)="",^PS(56,"APD",D2,R2,DA)="",TOT=TOT+2
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNDDI1 1306 printed Feb 18, 2025@23:50 Page 2
- PSNDDI1 ;BIR/SAB-BUILDS XREF IN DRUG INTERACTION FILE ;01/12/98 5:18
- +1 ;;4.0; NATIONAL DRUG FILE;; 30 Oct 98
- BEGIN DO XREF
- DO EX
- +1 QUIT
- XREF ;code to create 'APD' xref on Drug Interaction file (#56)
- +1 ;I '$D(ZTSK),'$D(PSMSG) D WAIT^DICD W "Building 'APD' X-Ref."
- +2 SET ID1=$PIECE(^PS(56,DA,0),"^",2)
- SET ID2=$PIECE(^(0),"^",3)
- SET TOT=0
- +3 FOR I1=0:0
- SET I1=$ORDER(^PS(50.416,ID1,1,I1))
- if 'I1
- QUIT
- SET R2=$PIECE(^(I1,0),"^")
- FOR I2=0:0
- SET I2=$ORDER(^PS(50.416,ID2,1,I2))
- if 'I2
- QUIT
- SET D2=$PIECE(^(I2,0),"^")
- if +$GET(PSMSG)
- WRITE "."
- DO SEC
- +4 FOR I1=0:0
- SET I1=$ORDER(^PS(50.416,"APS",ID1,I1))
- if 'I1
- QUIT
- FOR I3=0:0
- SET I3=$ORDER(^PS(50.416,I1,1,I3))
- if 'I3
- QUIT
- SET R2=$PIECE(^(I3,0),"^")
- FOR I5=0:0
- SET I5=$ORDER(^PS(50.416,"APS",ID2,I5))
- if 'I5
- QUIT
- FOR I6=0:0
- SET I6=$ORDER(^PS(50.416,I5,1,I6))
- if 'I6
- QUIT
- SET D2=$PIECE(^(I6,0),"^")
- DO SEC
- +5 FOR I1=0:0
- SET I1=$ORDER(^PS(50.416,ID1,1,I1))
- if 'I1
- QUIT
- SET R2=$PIECE(^(I1,0),"^")
- FOR I5=0:0
- SET I5=$ORDER(^PS(50.416,"APS",ID2,I5))
- if 'I5
- QUIT
- FOR I6=0:0
- SET I6=$ORDER(^PS(50.416,I5,1,I6))
- if 'I6
- QUIT
- SET D2=$PIECE(^(I6,0),"^")
- DO SEC
- +6 FOR I2=0:0
- SET I2=$ORDER(^PS(50.416,ID2,1,I2))
- if 'I2
- QUIT
- SET D2=$PIECE(^(I2,0),"^")
- FOR I1=0:0
- SET I1=$ORDER(^PS(50.416,"APS",ID1,I1))
- if 'I1
- QUIT
- FOR I3=0:0
- SET I3=$ORDER(^PS(50.416,I1,1,I3))
- if 'I3
- QUIT
- SET R2=$PIECE(^(I3,0),"^")
- DO SEC
- +7 SET $PIECE(^PS(56,DA,0),"^",6)=TOT
- EX KILL TOT,I5,I6,D2,I3,I1,I2,R2,ID2,ID1
- +1 QUIT
- SEC IF +$GET(DEL)
- KILL ^PS(56,"APD",R2,D2,DA),^PS(56,"APD",D2,R2,DA)
- QUIT
- +1 SET ^PS(56,"APD",R2,D2,DA)=""
- SET ^PS(56,"APD",D2,R2,DA)=""
- SET TOT=TOT+2
- +2 QUIT