PSNDDI1.m

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

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