- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSN4POST 2709 printed Apr 23, 2025@18:36:39 Page 2
- 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
