PSNCLEAN ;BIR/DMA-clean up ingredients and interactions ; 19 Aug 2008 9:42 AM
;;4.0;NATIONAL DRUG FILE;**117,176,513**; 3O Oct 98;Build 53
;
;Reference to ^GMR(120.8 supported by DBIA# 2545
;
N DA,DIE,DIK,DR,J,LINE,NA,NEWDA,PSN,PSNDA,PSNI,PSNI1,PSNI1N,PSNI1P,PSNI2,PSNI2N,PSNI2P,PSNN,PSNK,PSNPAT,PSNX,X,XMDUZ,XMSUB,XMTEXT,XMY
K ^TMP($J),^TMP("PSN",$J)
INTER ;CHECK FOR NON-PRIMARIES
S DA=0 F S DA=$O(^PS(56,DA)) Q:'DA S X=^(DA,0),PSNI1=$P(X,"^",2),PSNI2=$P(X,"^",3),PSNI1N=$P(^PS(50.416,PSNI1,0),"^",2),PSNI2N=$P(^PS(50.416,PSNI2,0),"^",2) D
.I 'PSNI1N,'PSNI2N Q
.S PSNI1P=$S('PSNI1N:PSNI1,1:PSNI1N),PSNI2P=$S('PSNI2N:PSNI2,1:PSNI2N)
.I '$D(^PS(56,"AE",PSNI1P,PSNI2P)) D Q
..;NO PRE-EXISTING INTERACTION - RENAME AND QUIT
..K PSN,PSNN S PSN($P(^PS(50.416,PSNI1P,0),"^"))="",PSN($P(^PS(50.416,PSNI2P,0),"^"))="",PSNN=$O(PSN(""))_"/"_$O(PSN($O(PSN("")))),^TMP($J,"RENAM",$P(X,"^")_"^"_PSNN)="",DIE="^PS(56,",DR=".01////"_PSNN D ^DIE
..K ^PS(56,"AI1",PSNI1,DA),^PS(56,"AI2",PSNI2,DA),^PS(56,"AE",PSNI1,PSNI2,DA),^PS(56,"AE",PSNI2,PSNI1,DA) S (^PS(56,"AI1",PSNI1P,DA),^PS(56,"AI2",PSNI2P,DA),^PS(56,"AE",PSNI1P,PSNI2P,DA),^PS(56,"AE",PSNI2P,PSNI1P,DA))=""
..S $P(^PS(56,DA,0),"^",2,3)=PSNI1P_"^"_PSNI2P
.;PRE-EXISTING INTERACTIONS - LOG TO DELETE
.S NEWDA=$QS($Q(^PS(56,"AE",PSNI1P,PSNI2P)),5) D
..S ^TMP($J,"DEL",$P(X,"^"))="",^TMP($J,"DELIEN",DA)=NEWDA
;NOW DELETE AND REPOINT
S PSN=0 F S PSN=$O(^TMP($J,"DELIEN",PSN)) Q:'PSN S X=^PS(56,PSN,0),PSNI1=$P(X,"^",2),PSNI2=$P(X,"^",3),$P(^PS(56,PSN,0),"^",2,7)="" K ^PS(56,"AI1",PSNI1,PSN),^PS(56,"AI2",PSNI2,PSN),^PS(56,"AE",PSNI1,PSNI2,PSN),^PS(56,"AE",PSNI2,PSNI1,PSN)
;NOW THE APD
S X="^PS(56,""APD"")" F S X=$Q(@X) Q:$QS(X,2)'="APD" I $D(^TMP($J,"DELIEN",$QS(X,5))) S NEWDA=^($QS(X,5)) K @X,^PS(56,"APD",$QS(X,4),$QS(X,3),$QS(X,5)) S (^PS(56,"APD",$QS(X,3),$QS(X,4),NEWDA),^PS(56,"APD",$QS(X,4),$QS(X,3),NEWDA))=""
;NOW THE 0 NODE
S PSN=0 F S PSN=$O(^TMP($J,"DELIEN",PSN)) Q:'PSN S DIK="^PS(56,",DA=PSN D ^DIK
;
I '$D(^TMP($J,"DEL")),'$D(^("RENAM")) D G ALLER
.F LINE=1:1 S X=$P($T(TEXT4+LINE),";",3,300) Q:X="" S ^TMP("PSN",$J,LINE,0)=X
F LINE=1:1 S X=$P($T(TEXT+LINE),";",3,300) Q:X="" S ^TMP("PSN",$J,LINE,0)=X
I '$D(^TMP($J,"RENAM")) S ^TMP("PSN",$J,LINE,0)=" ",^TMP("PSN",$J,LINE+1,0)="none found",LINE=LINE+2
S NA="" F S NA=$O(^TMP($J,"RENAM",NA)) Q:NA="" S ^TMP("PSN",$J,LINE,0)=$P(NA,"^")_" was changed to",^TMP("PSN",$J,LINE+1,0)=" "_$P(NA,"^",2),^TMP("PSN",$J,LINE+2,0)=" ",LINE=LINE+3
F J=1:1 S X=$P($T(TEXT2+J),";",3,300) Q:X="" S ^TMP("PSN",$J,LINE,0)=X,LINE=LINE+1
I '$D(^TMP($J,"DEL")) S ^TMP("PSN",$J,LINE,0)="none found",LINE=LINE+1
S NA="" F S NA=$O(^TMP($J,"DEL",NA)) Q:NA="" S ^TMP("PSN",$J,LINE,0)=NA,LINE=LINE+1
ALLER ;now the allergies
I ^XMB("NETNAME")["CMOP" G SENDIT
;skip allergies for CMOPs
K ^TMP($J)
S PSNDA=0 F S PSNDA=$O(^GMR(120.8,PSNDA)) Q:'PSNDA I $D(^(PSNDA,0)) S PSNPAT=+^(0) I $D(^DPT(PSNPAT,0)) S PSNPAT=$P(^(0),"^"),PSNI=$P(^GMR(120.8,PSNDA,0),"^",3) D
.I PSNI["PS(50.416",$D(^PS(50.416,+PSNI,0)),$P(^(0),"^",2) S PSNI=$P(^(0),"^",2)_";PS(50.416,",$P(^GMR(120.8,PSNDA,0),"^",3)=PSNI
.S PSNK=0 F S PSNK=$O(^GMR(120.8,PSNDA,2,PSNK)) Q:'PSNK S PSNI=^(PSNK,0) D
..S PSNX=$P(^PS(50.416,PSNI,0),"^",2) I PSNX S DA(1)=PSNDA,DA=PSNK,DIE="^GMR(120.8,DA(1),2,",DR=".01////"_$S($D(^GMR(120.8,DA(1),2,"B",PSNX)):"@",1:PSNX) D ^DIE S ^TMP($J,1,PSNPAT,$P(^PS(50.416,PSNI,0),"^")_"^"_$P(^PS(50.416,PSNX,0),"^"))=""
;
I '$D(^TMP($J,1)) D G SENDIT
.F J=1:1 S X=$P($T(TEXT5+J),";",3,300) Q:X="" S ^TMP("PSN",$J,LINE,0)=X,LINE=LINE+1
F J=1:1 S X=$P($T(TEXT3+J),";",3,300) Q:X="" S ^TMP("PSN",$J,LINE,0)=X,LINE=LINE+1
I '$D(^TMP($J,1)) S ^TMP("PSN",$J,LINE,0)="none found",LINE=LINE+1
S NA="" F S NA=$O(^TMP($J,1,NA)) Q:NA="" S X="" F S X=$O(^TMP($J,1,NA,X)) Q:X="" S ^TMP("PSN",$J,LINE,0)="Patient: "_NA,LINE=LINE+1,^TMP("PSN",$J,LINE,0)="Non-primary ingredient "_$P(X,"^"),LINE=LINE+1 D
.S ^TMP("PSN",$J,LINE,0)="was replaced with primary ingredient "_$P(X,"^",2),LINE=LINE+1,^TMP("PSN",$J,LINE,0)=" ",LINE=LINE+1
;
SENDIT ;
S XMSUB="INTERACTIONS and ALLERGIES UPDATED",XMDUZ="NDF MANAGER",XMTEXT="^TMP(""PSN"",$J," K XMY S XMY(DUZ)="",XMY("G.NDF DATA@"_^XMB("NETNAME"))="",DA=0 F S DA=$O(^XUSEC("PSNMGR",DA)) Q:'DA S XMY(DA)=""
N DIFROM D ^XMD
QUIT K DA,DIE,DIK,DR,J,LINE,NA,NEWDA,PSN,PSNDA,PSNI,PSNI1,PSNI1N,PSNI1P,PSNI2,PSNI2N,PSNI2P,PSNN,PSNK,PSNPAT,PSNX,X,XMDUZ,XMSUB,XMTEXT,XMY,^TMP($J),^TMP("PSN",$J)
PRO K ^TMP("PSN",$J) M ^TMP("PSN",$J)=@XPDGREF@("CLASS") K ^TMP("PSN",$J,0) I $D(^TMP("PSN",$J)) S ZTSAVE("^TMP(""PSN"",$J,")="",ZTIO="",ZTDTH=$H,ZTRTN="PROTO^PSNCLEAN" D ^%ZTLOAD K ZTSAVE,ZTIO,ZTDTH,ZTRTN Q
Q
PROTO S X="PSN NEW CLASS",DIC=101 D EN^XQOR K X,DIC Q
Q
TEXT3 ;
;;
;;=========================================================================
;;Allergy information for the following patients has been changed.
;;
;;The allergy for the listed patients was created with a non-primary
;;ingredient. These have been updated to replace the non-primary
;;ingredient with the proper primary ingredient.
;;
;
TEXT ;
;;
;;The following interactions have been edited because they
;;involved ingredients that are not primary ingredients.
;;
;
TEXT2 ;
;;
;;The following interactions have been deleted because
;;Primary Ingredient/Other Ingredient combination already
;;exists in the DRUG INGREDIENTS file involved ingredients
;;that are not primary ingredients.
;;
;
TEXT4 ;
;;
;;No DRUG INTERACTIONS were updated due to Primary Ingredients being
;;changed to Non-Primary ingredients in the Data Update.
;;
;
TEXT5 ;
;;
;;No PATIENT ALLERGIES were updated due to Primary Ingredients being
;;changed to Non-Primary ingredients during the Data Update.
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNCLEAN 5855 printed Sep 23, 2025@19:59:45 Page 2
PSNCLEAN ;BIR/DMA-clean up ingredients and interactions ; 19 Aug 2008 9:42 AM
+1 ;;4.0;NATIONAL DRUG FILE;**117,176,513**; 3O Oct 98;Build 53
+2 ;
+3 ;Reference to ^GMR(120.8 supported by DBIA# 2545
+4 ;
+5 NEW DA,DIE,DIK,DR,J,LINE,NA,NEWDA,PSN,PSNDA,PSNI,PSNI1,PSNI1N,PSNI1P,PSNI2,PSNI2N,PSNI2P,PSNN,PSNK,PSNPAT,PSNX,X,XMDUZ,XMSUB,XMTEXT,XMY
+6 KILL ^TMP($JOB),^TMP("PSN",$JOB)
INTER ;CHECK FOR NON-PRIMARIES
+1 SET DA=0
FOR
SET DA=$ORDER(^PS(56,DA))
if 'DA
QUIT
SET X=^(DA,0)
SET PSNI1=$PIECE(X,"^",2)
SET PSNI2=$PIECE(X,"^",3)
SET PSNI1N=$PIECE(^PS(50.416,PSNI1,0),"^",2)
SET PSNI2N=$PIECE(^PS(50.416,PSNI2,0),"^",2)
Begin DoDot:1
+2 IF 'PSNI1N
IF 'PSNI2N
QUIT
+3 SET PSNI1P=$SELECT('PSNI1N:PSNI1,1:PSNI1N)
SET PSNI2P=$SELECT('PSNI2N:PSNI2,1:PSNI2N)
+4 IF '$DATA(^PS(56,"AE",PSNI1P,PSNI2P))
Begin DoDot:2
+5 ;NO PRE-EXISTING INTERACTION - RENAME AND QUIT
+6 KILL PSN,PSNN
SET PSN($PIECE(^PS(50.416,PSNI1P,0),"^"))=""
SET PSN($PIECE(^PS(50.416,PSNI2P,0),"^"))=""
SET PSNN=$ORDER(PSN(""))_"/"_$ORDER(PSN($ORDER(PSN(""))))
SET ^TMP($JOB,"RENAM",$PIECE(X,"^")_"^"_PSNN)=""
SET DIE="^PS(56,"
SET DR=".01////"_PSNN
DO ^DIE
+7 KILL ^PS(56,"AI1",PSNI1,DA),^PS(56,"AI2",PSNI2,DA),^PS(56,"AE",PSNI1,PSNI2,DA),^PS(56,"AE",PSNI2,PSNI1,DA)
SET (^PS(56,"AI1",PSNI1P,DA),^PS(56,"AI2",PSNI2P,DA),^PS(56,"AE",PSNI1P,PSNI2P,DA),^PS(56,"AE",PSNI2P,PSNI1P,DA))=""
+8 SET $PIECE(^PS(56,DA,0),"^",2,3)=PSNI1P_"^"_PSNI2P
End DoDot:2
QUIT
+9 ;PRE-EXISTING INTERACTIONS - LOG TO DELETE
+10 SET NEWDA=$QSUBSCRIPT($QUERY(^PS(56,"AE",PSNI1P,PSNI2P)),5)
Begin DoDot:2
+11 SET ^TMP($JOB,"DEL",$PIECE(X,"^"))=""
SET ^TMP($JOB,"DELIEN",DA)=NEWDA
End DoDot:2
End DoDot:1
+12 ;NOW DELETE AND REPOINT
+13 SET PSN=0
FOR
SET PSN=$ORDER(^TMP($JOB,"DELIEN",PSN))
if 'PSN
QUIT
SET X=^PS(56,PSN,0)
SET PSNI1=$PIECE(X,"^",2)
SET PSNI2=$PIECE(X,"^",3)
SET $PIECE(^PS(56,PSN,0),"^",2,7)=""
KILL ^PS(56,"AI1",PSNI1,PSN),^PS(56,"AI2",PSNI2,PSN),^PS(56,"AE",PSNI1,PSNI2,PSN),^PS(56,"AE",PSNI2,PSNI1,PSN)
+14 ;NOW THE APD
+15 SET X="^PS(56,""APD"")"
FOR
SET X=$QUERY(@X)
if $QSUBSCRIPT(X,2)'="APD"
QUIT
IF $DATA(^TMP($JOB,"DELIEN",$QSUBSCRIPT(X,5)))
SET NEWDA=^($QSUBSCRIPT(X,5))
KILL @X,^PS(56,"APD",$QSUBSCRIPT(X,4),$QSUBSCRIPT(X,3),$QSUBSCRIPT(X,5))
SET (^PS(56,"APD",$QSUBSCRIPT(X,3),$QSUBSCRIPT(X,4),NEWDA),^PS(56,"APD",$QSUBSCRIPT(X,4),$QSUBSCRIPT(X,3),NEWDA))=""
+16 ;NOW THE 0 NODE
+17 SET PSN=0
FOR
SET PSN=$ORDER(^TMP($JOB,"DELIEN",PSN))
if 'PSN
QUIT
SET DIK="^PS(56,"
SET DA=PSN
DO ^DIK
+18 ;
+19 IF '$DATA(^TMP($JOB,"DEL"))
IF '$DATA(^("RENAM"))
Begin DoDot:1
+20 FOR LINE=1:1
SET X=$PIECE($TEXT(TEXT4+LINE),";",3,300)
if X=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=X
End DoDot:1
GOTO ALLER
+21 FOR LINE=1:1
SET X=$PIECE($TEXT(TEXT+LINE),";",3,300)
if X=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=X
+22 IF '$DATA(^TMP($JOB,"RENAM"))
SET ^TMP("PSN",$JOB,LINE,0)=" "
SET ^TMP("PSN",$JOB,LINE+1,0)="none found"
SET LINE=LINE+2
+23 SET NA=""
FOR
SET NA=$ORDER(^TMP($JOB,"RENAM",NA))
if NA=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=$PIECE(NA,"^")_" was changed to"
SET ^TMP("PSN",$JOB,LINE+1,0)=" "_$PIECE(NA,"^",2)
SET ^TMP("PSN",$JOB,LINE+2,0)=" "
SET LINE=LINE+3
+24 FOR J=1:1
SET X=$PIECE($TEXT(TEXT2+J),";",3,300)
if X=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=X
SET LINE=LINE+1
+25 IF '$DATA(^TMP($JOB,"DEL"))
SET ^TMP("PSN",$JOB,LINE,0)="none found"
SET LINE=LINE+1
+26 SET NA=""
FOR
SET NA=$ORDER(^TMP($JOB,"DEL",NA))
if NA=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=NA
SET LINE=LINE+1
ALLER ;now the allergies
+1 IF ^XMB("NETNAME")["CMOP"
GOTO SENDIT
+2 ;skip allergies for CMOPs
+3 KILL ^TMP($JOB)
+4 SET PSNDA=0
FOR
SET PSNDA=$ORDER(^GMR(120.8,PSNDA))
if 'PSNDA
QUIT
IF $DATA(^(PSNDA,0))
SET PSNPAT=+^(0)
IF $DATA(^DPT(PSNPAT,0))
SET PSNPAT=$PIECE(^(0),"^")
SET PSNI=$PIECE(^GMR(120.8,PSNDA,0),"^",3)
Begin DoDot:1
+5 IF PSNI["PS(50.416"
IF $DATA(^PS(50.416,+PSNI,0))
IF $PIECE(^(0),"^",2)
SET PSNI=$PIECE(^(0),"^",2)_";PS(50.416,"
SET $PIECE(^GMR(120.8,PSNDA,0),"^",3)=PSNI
+6 SET PSNK=0
FOR
SET PSNK=$ORDER(^GMR(120.8,PSNDA,2,PSNK))
if 'PSNK
QUIT
SET PSNI=^(PSNK,0)
Begin DoDot:2
+7 SET PSNX=$PIECE(^PS(50.416,PSNI,0),"^",2)
IF PSNX
SET DA(1)=PSNDA
SET DA=PSNK
SET DIE="^GMR(120.8,DA(1),2,"
SET DR=".01////"_$SELECT($DATA(^GMR(120.8,DA(1),2,"B",PSNX)):"@",1:PSNX)
DO ^DIE
SET ^TMP($JOB,1,PSNPAT,$PIECE(^PS(50.416,PSNI,0),"^")_"^"_$PIECE(^PS(50.416,PSNX,0),"^"))=""
End DoDot:2
End DoDot:1
+8 ;
+9 IF '$DATA(^TMP($JOB,1))
Begin DoDot:1
+10 FOR J=1:1
SET X=$PIECE($TEXT(TEXT5+J),";",3,300)
if X=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=X
SET LINE=LINE+1
End DoDot:1
GOTO SENDIT
+11 FOR J=1:1
SET X=$PIECE($TEXT(TEXT3+J),";",3,300)
if X=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=X
SET LINE=LINE+1
+12 IF '$DATA(^TMP($JOB,1))
SET ^TMP("PSN",$JOB,LINE,0)="none found"
SET LINE=LINE+1
+13 SET NA=""
FOR
SET NA=$ORDER(^TMP($JOB,1,NA))
if NA=""
QUIT
SET X=""
FOR
SET X=$ORDER(^TMP($JOB,1,NA,X))
if X=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)="Patient: "_NA
SET LINE=LINE+1
SET ^TMP("PSN",$JOB,LINE,0)="Non-primary ingredient "_$PIECE(X,"^")
SET LINE=LINE+1
Begin DoDot:1
+14 SET ^TMP("PSN",$JOB,LINE,0)="was replaced with primary ingredient "_$PIECE(X,"^",2)
SET LINE=LINE+1
SET ^TMP("PSN",$JOB,LINE,0)=" "
SET LINE=LINE+1
End DoDot:1
+15 ;
SENDIT ;
+1 SET XMSUB="INTERACTIONS and ALLERGIES UPDATED"
SET XMDUZ="NDF MANAGER"
SET XMTEXT="^TMP(""PSN"",$J,"
KILL XMY
SET XMY(DUZ)=""
SET XMY("G.NDF DATA@"_^XMB("NETNAME"))=""
SET DA=0
FOR
SET DA=$ORDER(^XUSEC("PSNMGR",DA))
if 'DA
QUIT
SET XMY(DA)=""
+2 NEW DIFROM
DO ^XMD
QUIT KILL DA,DIE,DIK,DR,J,LINE,NA,NEWDA,PSN,PSNDA,PSNI,PSNI1,PSNI1N,PSNI1P,PSNI2,PSNI2N,PSNI2P,PSNN,PSNK,PSNPAT,PSNX,X,XMDUZ,XMSUB,XMTEXT,XMY,^TMP($JOB),^TMP("PSN",$JOB)
PRO KILL ^TMP("PSN",$JOB)
MERGE ^TMP("PSN",$JOB)=@XPDGREF@("CLASS")
KILL ^TMP("PSN",$JOB,0)
IF $DATA(^TMP("PSN",$JOB))
SET ZTSAVE("^TMP(""PSN"",$J,")=""
SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTRTN="PROTO^PSNCLEAN"
DO ^%ZTLOAD
KILL ZTSAVE,ZTIO,ZTDTH,ZTRTN
QUIT
+1 QUIT
PROTO SET X="PSN NEW CLASS"
SET DIC=101
DO EN^XQOR
KILL X,DIC
QUIT
+1 QUIT
TEXT3 ;
+1 ;;
+2 ;;=========================================================================
+3 ;;Allergy information for the following patients has been changed.
+4 ;;
+5 ;;The allergy for the listed patients was created with a non-primary
+6 ;;ingredient. These have been updated to replace the non-primary
+7 ;;ingredient with the proper primary ingredient.
+8 ;;
+9 ;
TEXT ;
+1 ;;
+2 ;;The following interactions have been edited because they
+3 ;;involved ingredients that are not primary ingredients.
+4 ;;
+5 ;
TEXT2 ;
+1 ;;
+2 ;;The following interactions have been deleted because
+3 ;;Primary Ingredient/Other Ingredient combination already
+4 ;;exists in the DRUG INGREDIENTS file involved ingredients
+5 ;;that are not primary ingredients.
+6 ;;
+7 ;
TEXT4 ;
+1 ;;
+2 ;;No DRUG INTERACTIONS were updated due to Primary Ingredients being
+3 ;;changed to Non-Primary ingredients in the Data Update.
+4 ;;
+5 ;
TEXT5 ;
+1 ;;
+2 ;;No PATIENT ALLERGIES were updated due to Primary Ingredients being
+3 ;;changed to Non-Primary ingredients during the Data Update.
+4 ;;
