- PSN4P29 ;BIR/DMA-fix drug identifiers ;20 Mar 00 / 8:12 AM
- ;;4.0; NATIONAL DRUG FILE;**29**; 30 Oct 98
- ;
- S DA=0 F S DA=$O(^PS(50.416,DA)) Q:'DA K ^(DA,1)
- ;get rid of multiple
- ;
- S DA=0 F S DA=$O(^PSNDF(50.68,DA)),K=0 Q:'DA S PSN=$P(^(DA,0),"^",2)_"A"_DA D
- .K ^TMP($J) F S K=$O(^PSNDF(50.68,DA,2,K)) Q:'K S X=^(K,0),^TMP($J,+X)=X
- .K ^PSNDF(50.68,DA,2)
- .S J=0 F S J=$O(^TMP($J,J)) Q:'J S X=^(J),^PSNDF(50.68,DA,2,J,0)=X,J1=$O(^PS(50.416,J,1," "),-1)+1,^(J1,0)=PSN,^PS(50.416,J,1,"B",PSN,J1)=""
- ;now the zero nodes
- S DA=0 F S DA=$O(^PS(50.416,DA)) Q:'DA S X=$O(^PS(50.416,DA,1," "),-1),^PS(50.416,DA,1,0)="^50.4161A^"_X_"^"_X
- ;now 56
- K ^TMP($J) F J="AE","AI1","AI2","APD","C" K ^PS(56,J)
- S DA=0 F S DA=$O(^PS(56,DA)) Q:'DA S X=^(DA,0),NA=$P(X,"^"),I1=$P(X,"^",2),I2=$P(X,"^",3) D
- .S ^PS(56,"AE",I1,I2,DA)="",^PS(56,"AE",I2,I1,DA)=""
- .S ^PS(56,"AI1",I1,DA)=""
- .S ^PS(56,"AI2",I2,DA)=""
- .S ^PS(56,"C",$P(NA,"/"),DA)=""
- .S ^PS(56,"C",$P(NA,"/",2),DA)=""
- .K ^TMP($J) D
- ..S K=0 F S K=$O(^PS(50.416,I1,1,K)) Q:'K S X=^(K,0),^TMP($J,1,X)=""
- ..S K=0 F S K=$O(^PS(50.416,I2,1,K)) Q:'K S X=^(K,0),^TMP($J,2,X)=""
- ..S I11=0 F S I11=$O(^PS(50.416,"APS",I1,I11)),K=0 Q:'I11 F S K=$O(^PS(50.416,I11,1,K)) Q:'K S X=^(K,0),^TMP($J,1,X)=""
- ..S I22=0 F S I22=$O(^PS(50.416,"APS",I2,I22)),K=0 Q:'I22 F S K=$O(^PS(50.416,I22,1,K)) Q:'K S X=^(K,0),^TMP($J,2,X)=""
- .S D1="" F S D1=$O(^TMP($J,1,D1)) Q:D1="" S D2="" F S D2=$O(^TMP($J,2,D2)) Q:D2="" S ^PS(56,"APD",D1,D2,DA)="",^PS(56,"APD",D2,D1,DA)=""
- K D1,D2,DA,I1,I11,I2,I22,J,J1,K,NA,PSN,X,^TMP($J) Q
- PSN4P29 ;BIR/DMA-fix drug identifiers ;20 Mar 00 / 8:12 AM
- +1 ;;4.0; NATIONAL DRUG FILE;**29**; 30 Oct 98
- +2 ;
- +3 SET DA=0
- FOR
- SET DA=$ORDER(^PS(50.416,DA))
- IF 'DA
- QUIT
- KILL ^(DA,1)
- +4 ;get rid of multiple
- +5 ;
- +6 SET DA=0
- FOR
- SET DA=$ORDER(^PSNDF(50.68,DA))
- SET K=0
- IF 'DA
- QUIT
- SET PSN=$PIECE(^(DA,0),"^",2)_"A"_DA
- Begin DoDot:1
- +7 KILL ^TMP($JOB)
- FOR
- SET K=$ORDER(^PSNDF(50.68,DA,2,K))
- IF 'K
- QUIT
- SET X=^(K,0)
- SET ^TMP($JOB,+X)=X
- +8 KILL ^PSNDF(50.68,DA,2)
- +9 SET J=0
- FOR
- SET J=$ORDER(^TMP($JOB,J))
- IF 'J
- QUIT
- SET X=^(J)
- SET ^PSNDF(50.68,DA,2,J,0)=X
- SET J1=$ORDER(^PS(50.416,J,1," "),-1)+1
- SET ^(J1,0)=PSN
- SET ^PS(50.416,J,1,"B",PSN,J1)=""
- End DoDot:1
- +10 ;now the zero nodes
- +11 SET DA=0
- FOR
- SET DA=$ORDER(^PS(50.416,DA))
- IF 'DA
- QUIT
- SET X=$ORDER(^PS(50.416,DA,1," "),-1)
- SET ^PS(50.416,DA,1,0)="^50.4161A^"_X_"^"_X
- +12 ;now 56
- +13 KILL ^TMP($JOB)
- FOR J="AE","AI1","AI2","APD","C"
- KILL ^PS(56,J)
- +14 SET DA=0
- FOR
- SET DA=$ORDER(^PS(56,DA))
- IF 'DA
- QUIT
- SET X=^(DA,0)
- SET NA=$PIECE(X,"^")
- SET I1=$PIECE(X,"^",2)
- SET I2=$PIECE(X,"^",3)
- Begin DoDot:1
- +15 SET ^PS(56,"AE",I1,I2,DA)=""
- SET ^PS(56,"AE",I2,I1,DA)=""
- +16 SET ^PS(56,"AI1",I1,DA)=""
- +17 SET ^PS(56,"AI2",I2,DA)=""
- +18 SET ^PS(56,"C",$PIECE(NA,"/"),DA)=""
- +19 SET ^PS(56,"C",$PIECE(NA,"/",2),DA)=""
- +20 KILL ^TMP($JOB)
- Begin DoDot:2
- +21 SET K=0
- FOR
- SET K=$ORDER(^PS(50.416,I1,1,K))
- IF 'K
- QUIT
- SET X=^(K,0)
- SET ^TMP($JOB,1,X)=""
- +22 SET K=0
- FOR
- SET K=$ORDER(^PS(50.416,I2,1,K))
- IF 'K
- QUIT
- SET X=^(K,0)
- SET ^TMP($JOB,2,X)=""
- +23 SET I11=0
- FOR
- SET I11=$ORDER(^PS(50.416,"APS",I1,I11))
- SET K=0
- IF 'I11
- QUIT
- FOR
- SET K=$ORDER(^PS(50.416,I11,1,K))
- IF 'K
- QUIT
- SET X=^(K,0)
- SET ^TMP($JOB,1,X)=""
- +24 SET I22=0
- FOR
- SET I22=$ORDER(^PS(50.416,"APS",I2,I22))
- SET K=0
- IF 'I22
- QUIT
- FOR
- SET K=$ORDER(^PS(50.416,I22,1,K))
- IF 'K
- QUIT
- SET X=^(K,0)
- SET ^TMP($JOB,2,X)=""
- End DoDot:2
- +25 SET D1=""
- FOR
- SET D1=$ORDER(^TMP($JOB,1,D1))
- IF D1=""
- QUIT
- SET D2=""
- FOR
- SET D2=$ORDER(^TMP($JOB,2,D2))
- IF D2=""
- QUIT
- SET ^PS(56,"APD",D1,D2,DA)=""
- SET ^PS(56,"APD",D2,D1,DA)=""
- End DoDot:1
- +26 KILL D1,D2,DA,I1,I11,I2,I22,J,J1,K,NA,PSN,X,^TMP($JOB)
- QUIT
