PSN4POST ;BIR/DMA-post install routine to convert data in file 50 ;23 Jul 98 / 1:27 PM
;;4.0; NATIONAL DRUG FILE;; 30 Oct 98
;
N ROOT,ROOT1,DA,I,J,K,X,Y,A1,A2,B,IN,IN1,LINE
S ROOT=$NA(@XPDGREF@("LINE")),ROOT1=$NA(@XPDGREF@("CONV")),I=1
F J=1:1 Q:'$D(@ROOT@(J)) S LINE=^(J) F I=1:1:$L(LINE,"|")-1 S X=$P(LINE,"|",I),@ROOT1@($P(X,"^"),$P(X,"^",2))=$P(X,"^",3)
S DA=+$P($G(^PS(59.7,1,10)),"^",4) F S DA=$O(^PSDRUG(DA)) Q:'DA S X=$G(^(DA,"ND")),A=+X,B=+$P(X,"^",3) I A,B D
.I $D(@ROOT1@(A,B)) S X=^(B),$P(^PSDRUG(DA,"ND"),"^",3)=X
.E S $P(^PSDRUG(DA,"ND"),"^",1,5)="^^^^",X=$P(^("ND"),"^",10),$P(^("ND"),"^",10)="" I X]"" K ^PSDRUG("AQ1",X,DA)
.S $P(^PS(59.7,1,10),"^",4)=DA
I $P(^PS(59.7,1,10),"^")'="4.0" S ^PS(50.606,245,0)="AEROSOL,VAG",DIK="^PS(50.606,",DA=245 D IX^DIK
I $P(^PS(59.7,1,10),"^")'="4.0" S ^PS(50.606,246,0)="CAP/INJ",DIK="^PS(50.606,",DA=246 D IX^DIK
I $P(^PS(59.7,1,10),"^")'="4.0" S NUM=$O(^PS(51.2," "),-1),NUM=NUM+1,^PS(51.2,NUM,0)="ORAL/SUBCUTANEOUS^^PO SC",DIK="^PS(51.2,",DA=NUM D IX^DIK
I $P(^PS(59.7,1,10),"^")'="4.0" S NUM=$O(^PS(51.2," "),-1),NUM=NUM+1,^PS(51.2,NUM,0)="INTRAPLEURAL",DIK="^PS(51.2,",DA=NUM D IX^DIK
S $P(^PS(59.7,1,10),"^",5)=1
S $P(^PS(59.7,1,10),"^",1)="4.0"
;
;LOAD AND INDEX NATIONAL INTERACTIONS
S ROOT=$NA(@XPDGREF@("INTER")),DA=0
F S DA=$O(@ROOT@(DA)) Q:'DA S X=^(DA),^PS(56,DA,0)=X,^PS(56,"B",$E($P(X,"^"),1,30),DA)="",^PS(56,"C",$P(X,"/"),DA)="",^PS(56,"C",$P($P(X,"^"),"/",2),DA)="",A=$P(X,"^",2),B=$P(X,"^",3),^PS(56,"AE",A,B,DA)="",^PS(56,"AE",B,A,DA)=""
;NOW TRY TO UPDATE SEVERITIES
S ROOT=$NA(@XPDGREF@("OLD")),J=0
F S J=$O(@ROOT@(J)) Q:'J S X=^(J),DA=$O(^PS(56,"AE",$P(X,"^",2),$P(X,"^",3),0)) I DA S Y=^PS(56,DA,0) I $P(Y,"^",4)=2,$P(X,"^",4)=1 S $P(^(0),"^",4)=1,^("L")=1
;NOW LOAD AND INDEX LOCAL INTERACTIONS
S ROOT=$NA(@XPDGREF@("LOCAL"))
F DA=1:1 Q:'$D(@ROOT@(DA)) S X=^(DA),A=$P(X,"^",2),B=$P(X,"^",3),IN1=$O(^PS(56,"AE",A,B,0)) D
.I 'IN1 S IN=$O(^PS(56," "),-1)+1 S:IN<15000 IN=15000 S ^PS(56,IN,0)=X,^("L")=1,^PS(56,"B",$E($P(X,"^"),1,30),IN)="",A1=$P($P(X,"^"),"/"),A2=$P($P(X,"^"),"/",2) S:A1]"" ^PS(56,"C",A1,IN)="" S:A2]"" ^PS(56,"C",A2,IN)="" D
..S ^PS(56,"AE",A,B,IN)="",^PS(56,"AE",B,A,IN)=""
.I IN1,$P(^PS(56,IN1,0),"^",4)=2,$P(X,"^",4)=1 S $P(^PS(56,IN1,0),"^",4)=1,^("L")=1
;
;REINDEX "APD"
S DA=0 F S DA=$O(^PS(56,DA)) Q:'DA D ^PSNDDI1
;NOW HOUSEKEEPING
S LAST=$O(^PS(56," "),-1),DA=0 F I=0:1 S DA=$O(^PS(56,DA)) Q:'DA
S $P(^PS(56,0),"^",3,4)=LAST_"^"_I
;
ALERG ;NOW REDO ALLERGIES - SEE DBIA 2545
N IEN,VPT
S IEN=0 F S IEN=$O(^GMR(120.8,IEN)) Q:'IEN S VPT=$P($G(^(IEN,0)),"^",3) I VPT["PSNDF" S $P(^(0),"^",3)=+VPT_";PSNDF(50.6,"
;
Q
PSN4POST ;BIR/DMA-post install routine to convert data in file 50 ;23 Jul 98 / 1:27 PM
+1 ;;4.0; NATIONAL DRUG FILE;; 30 Oct 98
+2 ;
+3 NEW ROOT,ROOT1,DA,I,J,K,X,Y,A1,A2,B,IN,IN1,LINE
+4 SET ROOT=$NAME(@XPDGREF@("LINE"))
SET ROOT1=$NAME(@XPDGREF@("CONV"))
SET I=1
+5 FOR J=1:1
IF '$DATA(@ROOT@(J))
QUIT
SET LINE=^(J)
FOR I=1:1:$LENGTH(LINE,"|")-1
SET X=$PIECE(LINE,"|",I)
SET @ROOT1@($PIECE(X,"^"),$PIECE(X,"^",2))=$PIECE(X,"^",3)
+6 SET DA=+$PIECE($GET(^PS(59.7,1,10)),"^",4)
FOR
SET DA=$ORDER(^PSDRUG(DA))
IF 'DA
QUIT
SET X=$GET(^(DA,"ND"))
SET A=+X
SET B=+$PIECE(X,"^",3)
IF A
IF B
Begin DoDot:1
+7 IF $DATA(@ROOT1@(A,B))
SET X=^(B)
SET $PIECE(^PSDRUG(DA,"ND"),"^",3)=X
+8 IF '$TEST
SET $PIECE(^PSDRUG(DA,"ND"),"^",1,5)="^^^^"
SET X=$PIECE(^("ND"),"^",10)
SET $PIECE(^("ND"),"^",10)=""
IF X]""
KILL ^PSDRUG("AQ1",X,DA)
+9 SET $PIECE(^PS(59.7,1,10),"^",4)=DA
End DoDot:1
+10 IF $PIECE(^PS(59.7,1,10),"^")'="4.0"
SET ^PS(50.606,245,0)="AEROSOL,VAG"
SET DIK="^PS(50.606,"
SET DA=245
DO IX^DIK
+11 IF $PIECE(^PS(59.7,1,10),"^")'="4.0"
SET ^PS(50.606,246,0)="CAP/INJ"
SET DIK="^PS(50.606,"
SET DA=246
DO IX^DIK
+12 IF $PIECE(^PS(59.7,1,10),"^")'="4.0"
SET NUM=$ORDER(^PS(51.2," "),-1)
SET NUM=NUM+1
SET ^PS(51.2,NUM,0)="ORAL/SUBCUTANEOUS^^PO SC"
SET DIK="^PS(51.2,"
SET DA=NUM
DO IX^DIK
+13 IF $PIECE(^PS(59.7,1,10),"^")'="4.0"
SET NUM=$ORDER(^PS(51.2," "),-1)
SET NUM=NUM+1
SET ^PS(51.2,NUM,0)="INTRAPLEURAL"
SET DIK="^PS(51.2,"
SET DA=NUM
DO IX^DIK
+14 SET $PIECE(^PS(59.7,1,10),"^",5)=1
+15 SET $PIECE(^PS(59.7,1,10),"^",1)="4.0"
+16 ;
+17 ;LOAD AND INDEX NATIONAL INTERACTIONS
+18 SET ROOT=$NAME(@XPDGREF@("INTER"))
SET DA=0
+19 FOR
SET DA=$ORDER(@ROOT@(DA))
IF 'DA
QUIT
SET X=^(DA)
SET ^PS(56,DA,0)=X
SET ^PS(56,"B",$EXTRACT($PIECE(X,"^"),1,30),DA)=""
SET ^PS(56,"C",$PIECE(X,"/"),DA)=""
SET ^PS(56,"C",$PIECE($PIECE(X,"^"),"/",2),DA)=""
SET A=$PIECE(X,"^",2)
SET B=$PIECE(X,"^",3)
SET ^PS(56,"AE",A,B,DA)=""
SET ^PS(56,"AE",B,A,DA)=""
+20 ;NOW TRY TO UPDATE SEVERITIES
+21 SET ROOT=$NAME(@XPDGREF@("OLD"))
SET J=0
+22 FOR
SET J=$ORDER(@ROOT@(J))
IF 'J
QUIT
SET X=^(J)
SET DA=$ORDER(^PS(56,"AE",$PIECE(X,"^",2),$PIECE(X,"^",3),0))
IF DA
SET Y=^PS(56,DA,0)
IF $PIECE(Y,"^",4)=2
IF $PIECE(X,"^",4)=1
SET $PIECE(^(0),"^",4)=1
SET ^("L")=1
+23 ;NOW LOAD AND INDEX LOCAL INTERACTIONS
+24 SET ROOT=$NAME(@XPDGREF@("LOCAL"))
+25 FOR DA=1:1
IF '$DATA(@ROOT@(DA))
QUIT
SET X=^(DA)
SET A=$PIECE(X,"^",2)
SET B=$PIECE(X,"^",3)
SET IN1=$ORDER(^PS(56,"AE",A,B,0))
Begin DoDot:1
+26 IF 'IN1
SET IN=$ORDER(^PS(56," "),-1)+1
IF IN<15000
SET IN=15000
SET ^PS(56,IN,0)=X
SET ^("L")=1
SET ^PS(56,"B",$EXTRACT($PIECE(X,"^"),1,30),IN)=""
SET A1=$PIECE($PIECE(X,"^"),"/")
SET A2=$PIECE($PIECE(X,"^"),"/",2)
IF A1]""
SET ^PS(56,"C",A1,IN)=""
IF A2]""
SET ^PS(56,"C",A2,IN)=""
Begin DoDot:2
+27 SET ^PS(56,"AE",A,B,IN)=""
SET ^PS(56,"AE",B,A,IN)=""
End DoDot:2
+28 IF IN1
IF $PIECE(^PS(56,IN1,0),"^",4)=2
IF $PIECE(X,"^",4)=1
SET $PIECE(^PS(56,IN1,0),"^",4)=1
SET ^("L")=1
End DoDot:1
+29 ;
+30 ;REINDEX "APD"
+31 SET DA=0
FOR
SET DA=$ORDER(^PS(56,DA))
IF 'DA
QUIT
DO ^PSNDDI1
+32 ;NOW HOUSEKEEPING
+33 SET LAST=$ORDER(^PS(56," "),-1)
SET DA=0
FOR I=0:1
SET DA=$ORDER(^PS(56,DA))
IF 'DA
QUIT
+34 SET $PIECE(^PS(56,0),"^",3,4)=LAST_"^"_I
+35 ;
ALERG ;NOW REDO ALLERGIES - SEE DBIA 2545
+1 NEW IEN,VPT
+2 SET IEN=0
FOR
SET IEN=$ORDER(^GMR(120.8,IEN))
IF 'IEN
QUIT
SET VPT=$PIECE($GET(^(IEN,0)),"^",3)
IF VPT["PSNDF"
SET $PIECE(^(0),"^",3)=+VPT_";PSNDF(50.6,"
+3 ;
+4 QUIT
