PSNPPSCL ;BIR/DMA-clean up ingredients and interactions ; 19 Aug 2008 9:42 AM
;;4.0;NATIONAL DRUG FILE;**513,565**; 30 Oct 98;Build 16
;Reference to ^GMR(120.8 supported by DBIA #2545
;Reference to ^PS(59.7 supported by DBIA #2613
;
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,PSNLEG
K ^TMP($J),^TMP("PSN",$J)
INTER ;CHECK FOR NON-PRIMARIES
S LINE=1
I $G(PSNHLD)'="" S ^TMP("PSN",$J,LINE,0)="PPS-N Update File: "_$P(PSNHLD,";",1),LINE=LINE+1,^TMP("PSN",$J,LINE,0)="" ;add filename to top of file
D ENABLE^PSNPPSMS ;enable menu options - PBM decided this is where they want this to happen.
I $G(PSNSITET)'="" D CTRKDL^PSNPPSMS("Processing Interactions")
W:'$G(PSNSCJOB) !,"Processing Interactions...",!
S (PSNI1N,PSNI2N)="",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) D
.I 'PSNI1N,'PSNI2N Q
.S PSNI2N=$P(^PS(50.416,PSNI2,0),"^",2)
.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 J=1:1 S X=$P($T(TEXT4+J),";",3,300) Q:X="" S LINE=LINE+1,^TMP("PSN",$J,LINE,0)=X
F J=1:1 S X=$P($T(TEXT+J),";",3,300) Q:X="" S LINE=LINE+1,^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 $G(PSNSITET)'="" D CTRKDL^PSNPPSMS("Processing allergies")
W:'$G(PSNSCJOB) !,"Processing 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 ;
;
I $G(PSNSITET)'="" D CTRKDL^PSNPPSMS("Sending Interactions and allergies email")
;SETUP PRODUCTION OR SQA
N PSNPS,PSGRP
S PSNPS=$P($G(^PS(59.7,1,10)),"^",12)
S XMSUB="INTERACTIONS AND ALLERGIES UPDATED"
;S XMDUZ="NDF_MANAGER"
S XMDUZ="noreply@domain.ext"
S XMTEXT="^TMP(""PSN"",$J,"
K XMY
S XMY(DUZ)="",DA=0 F S DA=$O(^XUSEC("PSNMGR",DA)) Q:'DA S XMY(DA)=""
S PSNLEG="" S PSNLEG=$$GET1^DIQ(57.23,1,45) ;legacy update
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)=^TMP("PSN PPSN PARSED",$J,"CLASS")
N II,VAGEN,VADC,DATA,NDFKPR,NDFKD
S II=0 F S II=$O(^TMP("PSN PPSN PARSED",$J,"CLASS",II)) Q:II="" D
.S NDFKPR=II
.Q:'$D(^PSNDF(50.68,NDFKPR))
.S NDFKD=$G(^TMP("PSN PPSN PARSED",$J,"PRODS CHANGED CLASSES",NDFKPR))
.S $P(DATA,"^")=NDFKPR,$P(DATA,"^",2)=$P(NDFKD,"^",1) ;OLD DRUG CLASS IEN
.S $P(DATA,"^",3)=$P(NDFKD,"^",2) ;NEW DRUG CLASS IEN
.S $P(DATA,"^",4)=$P(NDFKD,"^",3) ;VA GENERIC IEN
.Q:$P(DATA,"^",2)=""!($P(DATA,"^",3)="")!($P(DATA,"^",4)="")
.S ^TMP("PSN",$J,NDFKPR,0)=DATA
;decision was made to not send the drug class emails, but we need to update the allergy files
I $D(^TMP("PSN",$J)) S ZTSAVE("^TMP(""PSN"",$J,")="",ZTIO="",ZTDTH=$H,ZTRTN="PROTO^PSNPPSCL" 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[HPSNPPSCL 7275 printed Sep 23, 2025@20:00:38 Page 2
PSNPPSCL ;BIR/DMA-clean up ingredients and interactions ; 19 Aug 2008 9:42 AM
+1 ;;4.0;NATIONAL DRUG FILE;**513,565**; 30 Oct 98;Build 16
+2 ;Reference to ^GMR(120.8 supported by DBIA #2545
+3 ;Reference to ^PS(59.7 supported by DBIA #2613
+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,PSNLEG
+6 KILL ^TMP($JOB),^TMP("PSN",$JOB)
INTER ;CHECK FOR NON-PRIMARIES
+1 SET LINE=1
+2 ;add filename to top of file
IF $GET(PSNHLD)'=""
SET ^TMP("PSN",$JOB,LINE,0)="PPS-N Update File: "_$PIECE(PSNHLD,";",1)
SET LINE=LINE+1
SET ^TMP("PSN",$JOB,LINE,0)=""
+3 ;enable menu options - PBM decided this is where they want this to happen.
DO ENABLE^PSNPPSMS
+4 IF $GET(PSNSITET)'=""
DO CTRKDL^PSNPPSMS("Processing Interactions")
+5 if '$GET(PSNSCJOB)
WRITE !,"Processing Interactions...",!
+6 SET (PSNI1N,PSNI2N)=""
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)
Begin DoDot:1
+7 IF 'PSNI1N
IF 'PSNI2N
QUIT
+8 SET PSNI2N=$PIECE(^PS(50.416,PSNI2,0),"^",2)
+9 SET PSNI1P=$SELECT('PSNI1N:PSNI1,1:PSNI1N)
SET PSNI2P=$SELECT('PSNI2N:PSNI2,1:PSNI2N)
+10 IF '$DATA(^PS(56,"AE",PSNI1P,PSNI2P))
Begin DoDot:2
+11 ;NO PRE-EXISTING INTERACTION - RENAME AND QUIT
+12 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
+13 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))=""
+14 SET $PIECE(^PS(56,DA,0),"^",2,3)=PSNI1P_"^"_PSNI2P
End DoDot:2
QUIT
+15 ;PRE-EXISTING INTERACTIONS - LOG TO DELETE
+16 SET NEWDA=$QSUBSCRIPT($QUERY(^PS(56,"AE",PSNI1P,PSNI2P)),5)
Begin DoDot:2
+17 SET ^TMP($JOB,"DEL",$PIECE(X,"^"))=""
SET ^TMP($JOB,"DELIEN",DA)=NEWDA
End DoDot:2
End DoDot:1
+18 ;NOW DELETE AND REPOINT
+19 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)
+20 ;NOW THE APD
+21 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))=""
+22 ;NOW THE 0 NODE
+23 SET PSN=0
FOR
SET PSN=$ORDER(^TMP($JOB,"DELIEN",PSN))
if 'PSN
QUIT
SET DIK="^PS(56,"
SET DA=PSN
DO ^DIK
+24 ;
+25 IF '$DATA(^TMP($JOB,"DEL"))
IF '$DATA(^("RENAM"))
Begin DoDot:1
+26 FOR J=1:1
SET X=$PIECE($TEXT(TEXT4+J),";",3,300)
if X=""
QUIT
SET LINE=LINE+1
SET ^TMP("PSN",$JOB,LINE,0)=X
End DoDot:1
GOTO ALLER
+27 FOR J=1:1
SET X=$PIECE($TEXT(TEXT+J),";",3,300)
if X=""
QUIT
SET LINE=LINE+1
SET ^TMP("PSN",$JOB,LINE,0)=X
+28 IF '$DATA(^TMP($JOB,"RENAM"))
SET ^TMP("PSN",$JOB,LINE,0)=" "
SET ^TMP("PSN",$JOB,LINE+1,0)="none found"
SET LINE=LINE+2
+29 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
+30 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
+31 IF '$DATA(^TMP($JOB,"DEL"))
SET ^TMP("PSN",$JOB,LINE,0)="none found"
SET LINE=LINE+1
+32 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 $GET(PSNSITET)'=""
DO CTRKDL^PSNPPSMS("Processing allergies")
+2 if '$GET(PSNSCJOB)
WRITE !,"Processing allergies...",!
+3 IF ^XMB("NETNAME")["CMOP"
GOTO SENDIT
+4 ;skip allergies for CMOPs
+5 KILL ^TMP($JOB)
+6 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
+7 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
+8 SET PSNK=0
FOR
SET PSNK=$ORDER(^GMR(120.8,PSNDA,2,PSNK))
if 'PSNK
QUIT
SET PSNI=^(PSNK,0)
Begin DoDot:2
+9 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
+10 ;
+11 IF '$DATA(^TMP($JOB,1))
Begin DoDot:1
+12 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
+13 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
+14 IF '$DATA(^TMP($JOB,1))
SET ^TMP("PSN",$JOB,LINE,0)="none found"
SET LINE=LINE+1
+15 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
+16 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
+17 ;
SENDIT ;
+1 ;
+2 IF $GET(PSNSITET)'=""
DO CTRKDL^PSNPPSMS("Sending Interactions and allergies email")
+3 ;SETUP PRODUCTION OR SQA
+4 NEW PSNPS,PSGRP
+5 SET PSNPS=$PIECE($GET(^PS(59.7,1,10)),"^",12)
+6 SET XMSUB="INTERACTIONS AND ALLERGIES UPDATED"
+7 ;S XMDUZ="NDF_MANAGER"
+8 SET XMDUZ="noreply@domain.ext"
+9 SET XMTEXT="^TMP(""PSN"",$J,"
+10 KILL XMY
+11 SET XMY(DUZ)=""
SET DA=0
FOR
SET DA=$ORDER(^XUSEC("PSNMGR",DA))
if 'DA
QUIT
SET XMY(DA)=""
+12 ;legacy update
SET PSNLEG=""
SET PSNLEG=$$GET1^DIQ(57.23,1,45)
+13 NEW DIFROM
DO ^XMD
+14 ;
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 ;M ^TMP("PSN",$J)=^TMP("PSN PPSN PARSED",$J,"CLASS")
KILL ^TMP("PSN",$JOB)
+1 NEW II,VAGEN,VADC,DATA,NDFKPR,NDFKD
+2 SET II=0
FOR
SET II=$ORDER(^TMP("PSN PPSN PARSED",$JOB,"CLASS",II))
if II=""
QUIT
Begin DoDot:1
+3 SET NDFKPR=II
+4 if '$DATA(^PSNDF(50.68,NDFKPR))
QUIT
+5 SET NDFKD=$GET(^TMP("PSN PPSN PARSED",$JOB,"PRODS CHANGED CLASSES",NDFKPR))
+6 ;OLD DRUG CLASS IEN
SET $PIECE(DATA,"^")=NDFKPR
SET $PIECE(DATA,"^",2)=$PIECE(NDFKD,"^",1)
+7 ;NEW DRUG CLASS IEN
SET $PIECE(DATA,"^",3)=$PIECE(NDFKD,"^",2)
+8 ;VA GENERIC IEN
SET $PIECE(DATA,"^",4)=$PIECE(NDFKD,"^",3)
+9 if $PIECE(DATA,"^",2)=""!($PIECE(DATA,"^",3)="")!($PIECE(DATA,"^",4)="")
QUIT
+10 SET ^TMP("PSN",$JOB,NDFKPR,0)=DATA
End DoDot:1
+11 ;decision was made to not send the drug class emails, but we need to update the allergy files
+12 IF $DATA(^TMP("PSN",$JOB))
SET ZTSAVE("^TMP(""PSN"",$J,")=""
SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTRTN="PROTO^PSNPPSCL"
DO ^%ZTLOAD
KILL ZTSAVE,ZTIO,ZTDTH,ZTRTN
QUIT
+13 QUIT
+14 ;
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 ;;
