PSNCLING ;BIR/DMA-clean up ingredients and interactions ; 19 Jan 2006 9:45 AM
;;4.0; NATIONAL DRUG FILE;**107**; 3O Oct 98
;
;Reference to ^GMRD(120.8 supported by DBIA# 2545
;Reference to ADCOM^GMRAFX supported by DBIA# 4783
;
;delete existing cross reference
K ^PS(50.416,"P")
;and the entries
;
;following code generated by DIKCBLD
N PSNXR,PSNRES,PSNOUT
S PSNXR("FILE")=50.416
S PSNXR("NAME")="P1"
S PSNXR("TYPE")="MU"
S PSNXR("USE")="LS"
S PSNXR("EXECUTION")="R"
S PSNXR("ACTIVITY")="IR"
S PSNXR("SHORT DESCR")="CROSS REFERENCE ON PRIMARY INGREDIENT"
S PSNXR("DESCR",1)=" "
S PSNXR("SET")="I X2(1)'="""",X2(2)="""" S ^PS(50.416,""P"",X2(1),DA)="""""
S PSNXR("KILL")="I X2(1)=""""!(X2(2)'="""")!(X1(1)'=X2(1)) K ^PS(50.416,""P"",X1(1),DA)"
S PSNXR("WHOLE KILL")="K ^PS(50.416,""P"")"
S PSNXR("VAL",1)=.01
S PSNXR("VAL",1,"COLLATION")="F"
S PSNXR("VAL",2)=2
S PSNXR("VAL",2,"COLLATION")="F"
D CREIXN^DDMOD(.PSNXR,"SW",.PSNRES,"PSNOUT")
;end of generated code
;
N DA,DIE,DIK,DR,J,LINE,NA,OLD,PSN,PSN1,PSN11,PSN2,PSN21,PSNA1,PSNA2,PSNDA,PSNFREE,PSNI,PSNI1,PSNI2,PSNPAT,PSNPSNI1,PSNK,PSNN,PSNN1,PSNQ,PSNX,X,XMDUZ,XMSUB,XMTEXT,XMY
K ^TMP($J),^TMP("PSN",$J)
S DA=4254
F S DA=$O(^PS(50.416,DA)) Q:'DA S X=$P(^(DA,0),"^"),^TMP($J,X)="",DIK="^PS(50.416," D ^DIK
;
MESSAGE ;
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)) S ^TMP("PSN",$J,LINE,0)="none found",LINE=LINE+1
S NA="" F LINE=LINE:1 S NA=$O(^TMP($J,NA)) Q:NA="" S ^TMP("PSN",$J,LINE,0)=NA
;
;
;now the interactions
K ^TMP($J)
;
S DA=14999 F S DA=$O(^PS(56,DA)) Q:'DA S X=^(DA,0),OLD=$P(X,"^") K PSN,PSNN D
.S PSNI1=$P(X,"^",2),PSNI2=$P(X,"^",3) I '$D(^PS(50.416,PSNI1,0))!'$D(^PS(50.416,PSNI2,0)) S ^TMP($J,1,OLD)="",DIK="^PS(56," D ^DIK Q
.S PSN($P(^PS(50.416,PSNI1,0),"^"))="",PSN($P(^PS(50.416,PSNI2,0),"^"))="",PSNN=$O(PSN(""))_"/"_$O(PSN($O(PSN("")))),PSNQ=0 I PSNN'=OLD D Q:PSNQ
..S PSNN1=$P(PSNN,"/",2)_"/"_$P(PSNN,"/") I PSNN1=OLD S DIE="^PS(56,",DR=".01////"_PSNN D ^DIE Q
..S ^TMP($J,2,OLD)=PSNN,DIK="^PS(56," D ^DIK S PSNQ=1 Q
.S X=$P(^PS(50.416,PSNI1,0),"^",2) I X S $P(^PS(56,DA,0),"^",2)=X,PSNI1=X
.S X=$P(^PS(50.416,PSNI2,0),"^",2) I X S $P(^PS(56,DA,0),"^",3)=X,PSNI2=X
.K PSN,PSNN S PSN($P(^PS(50.416,PSNI1,0),"^"))="",PSN($P(^PS(50.416,PSNI2,0),"^"))="",PSNN=$O(PSN(""))_"/"_$O(PSN($O(PSN("")))) I PSNN'=OLD S DIE="^PS(56,",DR=".01////"_PSNN_";" D
..I $O(^PS(56,"B",PSNN,0)),$O(^(0))'=DA S DIK="^PS(56," D ^DIK Q
..D ^DIE S ^TMP($J,3,OLD)=PSNN
;
;now the APD
K ^PS(50.416,"APD") S DA=0 F S DA=$O(^PS(50.416,DA)),K=0 Q:'DA F S K=$O(^PS(50.416,DA,1,K)) Q:'K S X=^(K,0),^PS(50.416,"APD",X,DA)=""
;now the interactions
K ^PS(56,"APD") S DA=0 F S DA=$O(^PS(56,DA)) Q:'DA K PSN1,PSN2 S PSN1=$P(^(DA,0),"^",2),PSN2=$P(^(0),"^",3) D
.S NA="" F S NA=$O(^PS(50.416,PSN1,1,"B",NA)) Q:NA="" S PSN1(NA)=""
.S PSN11=0 F S PSN11=$O(^PS(50.416,"APS",PSN1,PSN11)),NA="" Q:'PSN11 F S NA=$O(^PS(50.416,PSN11,1,"B",NA)) Q:NA="" S PSN1(NA)=""
.S NA="" F S NA=$O(^PS(50.416,PSN2,1,"B",NA)) Q:NA="" S PSN2(NA)=""
.S PSN21=0 F S PSN21=$O(^PS(50.416,"APS",PSN2,PSN21)),NA="" Q:'PSN21 F S NA=$O(^PS(50.416,PSN21,1,"B",NA)) Q:NA="" S PSN2(NA)=""
.S PSN1="" F S PSN1=$O(PSN1(PSN1)),PSN2="" Q:PSN1="" F S PSN2=$O(PSN2(PSN2)) Q:PSN2="" S ^PS(56,"APD",PSN1,PSN2,DA)="",^PS(56,"APD",PSN2,PSN1,DA)=""
;
MORE ;MESSAGE CONTINUED
F J=1:1 S X=$P($T(TEXT1+J),";",3) Q:X="" S ^TMP("PSN",$J,LINE,0)=X,LINE=LINE+1
I '$D(^TMP($J,2)) S ^TMP("PSN",$J,LINE,0)="none found" S LINE=LINE+1
S NA="" F S NA=$O(^TMP($J,2,NA)) Q:NA="" Q:NA="^" S X=^(NA),^TMP("PSN",$J,LINE,0)="Name: "_NA,LINE=LINE+1,^TMP("PSN",$J,LINE,0)="Actual Ingredients: "_X,LINE=LINE+1,^TMP("PSN",$J,LINE,0)=" ",LINE=LINE+1
;
;
F J=1:1 S X=$P($T(TEXT2+J),";",3) Q:X="" S ^TMP("PSN",$J,LINE,0)=X,LINE=LINE+1
I $O(^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 ^TMP("PSN",$J,LINE,0)=NA,LINE=LINE+1
F J=1:1 S X=$P($T(TEXT2A+J),";",3) Q:X="" S ^TMP("PSN",$J,LINE,0)=X,LINE=LINE+1
I $O(^TMP($J,3,""))="" S ^TMP("PSN",$J,LINE,0)="none found",LINE=LINE+1
S NA="" F S NA=$O(^TMP($J,3,NA)) Q:NA="" S X=^(NA),^TMP("PSN",$J,LINE,0)="Interaction "_NA,LINE=LINE+1,^TMP("PSN",$J,LINE,0)="was changed to "_X,LINE=LINE+1,^TMP("PSN",$J,LINE,0)=" ",LINE=LINE+1
;
ALLER ;now the allergies
I ^XMB("NETNAME")["CMOP" G INTER
;skip allergies for CMOPs
K ^TMP($J)
S PSNFREE=$O(^GMRD(120.82,"B","OTHER ALLERGY/ADVERSE REACTION",0))_";GMRD(120,82,"
S PSNDA=0 F S PSNDA=$O(^GMR(120.8,PSNDA)) Q:'PSNDA S PSNPAT=+^(PSNDA,0),PSNPAT=$P(^DPT(PSNPAT,0),"^") D
.S PSNI=$P(^GMR(120.8,PSNDA,0),"^",3) I PSNI["PS(50.416",'$D(^PS(50.416,+PSNI,0)) S $P(^GMR(120.8,PSNDA,0),"^",3)=PSNFREE S DIE="^GMR(120.8,",DA=PSNDA,DR="22////1;23////"_$$NOW^XLFDT_";24////"_DUZ_";" D ^DIE S ^TMP($J,2,PSNPAT)="" D
..D ADCOM^GMRAFX(PSNDA,"E","Marked entered in error by patch PSN*4*107")
.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
..I '$D(^PS(50.416,PSNI,0)) S DA(1)=PSNDA,DA=PSNK,DIE="^GMR(120.8,DA(1),2,",DR=".01///@" D ^DIE S ^TMP($J,2,PSNPAT)="" Q
..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),"^"))=""
;
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
F J=1:1 S X=$P($T(TEXT5+J),";",3,300) Q:X="" S ^TMP("PSN",$J,LINE,0)=X,LINE=LINE+1
I '$D(^TMP($J,2)) S ^TMP("PSN",$J,LINE,0)="none found",LINE=LINE+1
S NA="" F S NA=$O(^TMP($J,2,NA)) Q:NA="" S ^TMP("PSN",$J,LINE,0)=NA,LINE=LINE+1
;
INTER K PSN1 S PSN2=$P($T(LIST),";",3) F J=1:1:$L(PSN2,"^")-1 S PSN1($P(PSN2,"^",J))=""
K ^TMP($J) S DA=0 F S DA=$O(^PS(56,DA)) Q:'DA Q:DA>14999 I '$D(PSN1(DA)) S X=^(DA,0),OLD=$P(X,"^"),PSNI1=$P(X,"^",2),PSNI2=$P(X,"^",3) K PSN,PSNN D
.S PSN($P(^PS(50.416,PSNI1,0),"^"))="",PSN($P(^PS(50.416,PSNI2,0),"^"))="",PSNN=$O(PSN(""))_"/"_$O(PSN($O(PSN("")))) I PSNN'=OLD S ^TMP($J,OLD_"^"_DA)=""
F J=1:1 S X=$P($T(TEXT6+J),";",3,300) Q:X="" S ^TMP("PSN",$J,LINE,0)=X,LINE=LINE+1
I '$D(^TMP($J)) S ^TMP("PSN",$J,LINE,0)="none found",LINE=LINE+1
S NA="" F S NA=$O(^TMP($J,NA)) Q:NA="" S ^TMP("PSN",$J,LINE,0)=$P(NA,"^",2) S $E(^(0),12)=$P(NA,"^"),LINE=LINE+1
SENDIT ;
S XMSUB="INGREDIENTS AND INTERACTIONS DELETED",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
K DA,DIE,DIK,DR,J,K,LINE,NA,OLD,PSN,PSN1,PSN11,PSN2,PSN21,PSNA1,PSNA2,PSNDA,PSNFREE,PSNI,PSNI1,PSNI2,PSNAPT,PSNPSNI1,PSNK,PSNX,PSNN,PSNN1,PSNQ,X,XMDUZ,XMSUB,XMTEXT,XMY,^TMP($J),^TMP("PSN",$J)
Q
TEXT ;
;;The following locally added ingredients have been deleted from the
;;INGREDIENTS file (#50.416).
;;
;
TEXT1 ;
;;============================================================================
;;
;;The following locally added interactions have been deleted from the
;;DRUG INTERACTIONS file (#56) because they check for ingredients other
;;than those indicated by the name.
;;
;;
;
;;
TEXT2 ;
;;============================================================================
;;
;;The following locally added interactions have been deleted from the
;;DRUG INTERACTIONS file (#56) because they involve locally entered
;;ingredients which have been deleted.
;;
;;
;
TEXT2A ;
;;========================================================================
;;
;;The following locally added interactions have been edited because they
;;involved ingredients that are not primary ingredients.
;;
;;
;;
;
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.
;;
TEXT5 ;
;;
;;========================================================================
;;The patient allergy entries for the listed patients were created with
;;locally added ingredients. Locally added ingredients are not supported
;;by the software and the allergies have been updated to 'entered in error'.
;;The patient allergy entry should be reviewed.
;;
;
TEXT6 ;
;;
;;========================================================================
;;
;;The following nationally entered interactions have a discrepancy
;;between the name and the ingredients. Please submit a remedy ticket
;;and attach the information in this section so that the proper cleanup
;;can be done.
;;
;;IEN Interaction
;;
;
LIST ;;2084^2085^2086^2087^2088^2089^2090^2091^2092^2093^2094^2095^2096^2136^2237^2238^2239^2244^2289^
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNCLING 9666 printed Apr 09, 2024@21:23:29 Page 2
PSNCLING ;BIR/DMA-clean up ingredients and interactions ; 19 Jan 2006 9:45 AM
+1 ;;4.0; NATIONAL DRUG FILE;**107**; 3O Oct 98
+2 ;
+3 ;Reference to ^GMRD(120.8 supported by DBIA# 2545
+4 ;Reference to ADCOM^GMRAFX supported by DBIA# 4783
+5 ;
+6 ;delete existing cross reference
+7 KILL ^PS(50.416,"P")
+8 ;and the entries
+9 ;
+10 ;following code generated by DIKCBLD
+11 NEW PSNXR,PSNRES,PSNOUT
+12 SET PSNXR("FILE")=50.416
+13 SET PSNXR("NAME")="P1"
+14 SET PSNXR("TYPE")="MU"
+15 SET PSNXR("USE")="LS"
+16 SET PSNXR("EXECUTION")="R"
+17 SET PSNXR("ACTIVITY")="IR"
+18 SET PSNXR("SHORT DESCR")="CROSS REFERENCE ON PRIMARY INGREDIENT"
+19 SET PSNXR("DESCR",1)=" "
+20 SET PSNXR("SET")="I X2(1)'="""",X2(2)="""" S ^PS(50.416,""P"",X2(1),DA)="""""
+21 SET PSNXR("KILL")="I X2(1)=""""!(X2(2)'="""")!(X1(1)'=X2(1)) K ^PS(50.416,""P"",X1(1),DA)"
+22 SET PSNXR("WHOLE KILL")="K ^PS(50.416,""P"")"
+23 SET PSNXR("VAL",1)=.01
+24 SET PSNXR("VAL",1,"COLLATION")="F"
+25 SET PSNXR("VAL",2)=2
+26 SET PSNXR("VAL",2,"COLLATION")="F"
+27 DO CREIXN^DDMOD(.PSNXR,"SW",.PSNRES,"PSNOUT")
+28 ;end of generated code
+29 ;
+30 NEW DA,DIE,DIK,DR,J,LINE,NA,OLD,PSN,PSN1,PSN11,PSN2,PSN21,PSNA1,PSNA2,PSNDA,PSNFREE,PSNI,PSNI1,PSNI2,PSNPAT,PSNPSNI1,PSNK,PSNN,PSNN1,PSNQ,PSNX,X,XMDUZ,XMSUB,XMTEXT,XMY
+31 KILL ^TMP($JOB),^TMP("PSN",$JOB)
+32 SET DA=4254
+33 FOR
SET DA=$ORDER(^PS(50.416,DA))
if 'DA
QUIT
SET X=$PIECE(^(DA,0),"^")
SET ^TMP($JOB,X)=""
SET DIK="^PS(50.416,"
DO ^DIK
+34 ;
MESSAGE ;
+1 FOR LINE=1:1
SET X=$PIECE($TEXT(TEXT+LINE),";",3,300)
if X=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=X
+2 IF '$DATA(^TMP($JOB))
SET ^TMP("PSN",$JOB,LINE,0)="none found"
SET LINE=LINE+1
+3 SET NA=""
FOR LINE=LINE:1
SET NA=$ORDER(^TMP($JOB,NA))
if NA=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=NA
+4 ;
+5 ;
+6 ;now the interactions
+7 KILL ^TMP($JOB)
+8 ;
+9 SET DA=14999
FOR
SET DA=$ORDER(^PS(56,DA))
if 'DA
QUIT
SET X=^(DA,0)
SET OLD=$PIECE(X,"^")
KILL PSN,PSNN
Begin DoDot:1
+10 SET PSNI1=$PIECE(X,"^",2)
SET PSNI2=$PIECE(X,"^",3)
IF '$DATA(^PS(50.416,PSNI1,0))!'$DATA(^PS(50.416,PSNI2,0))
SET ^TMP($JOB,1,OLD)=""
SET DIK="^PS(56,"
DO ^DIK
QUIT
+11 SET PSN($PIECE(^PS(50.416,PSNI1,0),"^"))=""
SET PSN($PIECE(^PS(50.416,PSNI2,0),"^"))=""
SET PSNN=$ORDER(PSN(""))_"/"_$ORDER(PSN($ORDER(PSN(""))))
SET PSNQ=0
IF PSNN'=OLD
Begin DoDot:2
+12 SET PSNN1=$PIECE(PSNN,"/",2)_"/"_$PIECE(PSNN,"/")
IF PSNN1=OLD
SET DIE="^PS(56,"
SET DR=".01////"_PSNN
DO ^DIE
QUIT
+13 SET ^TMP($JOB,2,OLD)=PSNN
SET DIK="^PS(56,"
DO ^DIK
SET PSNQ=1
QUIT
End DoDot:2
if PSNQ
QUIT
+14 SET X=$PIECE(^PS(50.416,PSNI1,0),"^",2)
IF X
SET $PIECE(^PS(56,DA,0),"^",2)=X
SET PSNI1=X
+15 SET X=$PIECE(^PS(50.416,PSNI2,0),"^",2)
IF X
SET $PIECE(^PS(56,DA,0),"^",3)=X
SET PSNI2=X
+16 KILL PSN,PSNN
SET PSN($PIECE(^PS(50.416,PSNI1,0),"^"))=""
SET PSN($PIECE(^PS(50.416,PSNI2,0),"^"))=""
SET PSNN=$ORDER(PSN(""))_"/"_$ORDER(PSN($ORDER(PSN(""))))
IF PSNN'=OLD
SET DIE="^PS(56,"
SET DR=".01////"_PSNN_";"
Begin DoDot:2
+17 IF $ORDER(^PS(56,"B",PSNN,0))
IF $ORDER(^(0))'=DA
SET DIK="^PS(56,"
DO ^DIK
QUIT
+18 DO ^DIE
SET ^TMP($JOB,3,OLD)=PSNN
End DoDot:2
End DoDot:1
+19 ;
+20 ;now the APD
+21 KILL ^PS(50.416,"APD")
SET DA=0
FOR
SET DA=$ORDER(^PS(50.416,DA))
SET K=0
if 'DA
QUIT
FOR
SET K=$ORDER(^PS(50.416,DA,1,K))
if 'K
QUIT
SET X=^(K,0)
SET ^PS(50.416,"APD",X,DA)=""
+22 ;now the interactions
+23 KILL ^PS(56,"APD")
SET DA=0
FOR
SET DA=$ORDER(^PS(56,DA))
if 'DA
QUIT
KILL PSN1,PSN2
SET PSN1=$PIECE(^(DA,0),"^",2)
SET PSN2=$PIECE(^(0),"^",3)
Begin DoDot:1
+24 SET NA=""
FOR
SET NA=$ORDER(^PS(50.416,PSN1,1,"B",NA))
if NA=""
QUIT
SET PSN1(NA)=""
+25 SET PSN11=0
FOR
SET PSN11=$ORDER(^PS(50.416,"APS",PSN1,PSN11))
SET NA=""
if 'PSN11
QUIT
FOR
SET NA=$ORDER(^PS(50.416,PSN11,1,"B",NA))
if NA=""
QUIT
SET PSN1(NA)=""
+26 SET NA=""
FOR
SET NA=$ORDER(^PS(50.416,PSN2,1,"B",NA))
if NA=""
QUIT
SET PSN2(NA)=""
+27 SET PSN21=0
FOR
SET PSN21=$ORDER(^PS(50.416,"APS",PSN2,PSN21))
SET NA=""
if 'PSN21
QUIT
FOR
SET NA=$ORDER(^PS(50.416,PSN21,1,"B",NA))
if NA=""
QUIT
SET PSN2(NA)=""
+28 SET PSN1=""
FOR
SET PSN1=$ORDER(PSN1(PSN1))
SET PSN2=""
if PSN1=""
QUIT
FOR
SET PSN2=$ORDER(PSN2(PSN2))
if PSN2=""
QUIT
SET ^PS(56,"APD",PSN1,PSN2,DA)=""
SET ^PS(56,"APD",PSN2,PSN1,DA)=""
End DoDot:1
+29 ;
MORE ;MESSAGE CONTINUED
+1 FOR J=1:1
SET X=$PIECE($TEXT(TEXT1+J),";",3)
if X=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=X
SET LINE=LINE+1
+2 IF '$DATA(^TMP($JOB,2))
SET ^TMP("PSN",$JOB,LINE,0)="none found"
SET LINE=LINE+1
+3 SET NA=""
FOR
SET NA=$ORDER(^TMP($JOB,2,NA))
if NA=""
QUIT
if NA="^"
QUIT
SET X=^(NA)
SET ^TMP("PSN",$JOB,LINE,0)="Name: "_NA
SET LINE=LINE+1
SET ^TMP("PSN",$JOB,LINE,0)="Actual Ingredients: "_X
SET LINE=LINE+1
SET ^TMP("PSN",$JOB,LINE,0)=" "
SET LINE=LINE+1
+4 ;
+5 ;
+6 FOR J=1:1
SET X=$PIECE($TEXT(TEXT2+J),";",3)
if X=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=X
SET LINE=LINE+1
+7 IF $ORDER(^TMP($JOB,1,""))=""
SET ^TMP("PSN",$JOB,LINE,0)="none found"
SET LINE=LINE+1
+8 SET NA=""
FOR
SET NA=$ORDER(^TMP($JOB,1,NA))
if NA=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=NA
SET LINE=LINE+1
+9 FOR J=1:1
SET X=$PIECE($TEXT(TEXT2A+J),";",3)
if X=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=X
SET LINE=LINE+1
+10 IF $ORDER(^TMP($JOB,3,""))=""
SET ^TMP("PSN",$JOB,LINE,0)="none found"
SET LINE=LINE+1
+11 SET NA=""
FOR
SET NA=$ORDER(^TMP($JOB,3,NA))
if NA=""
QUIT
SET X=^(NA)
SET ^TMP("PSN",$JOB,LINE,0)="Interaction "_NA
SET LINE=LINE+1
SET ^TMP("PSN",$JOB,LINE,0)="was changed to "_X
SET LINE=LINE+1
SET ^TMP("PSN",$JOB,LINE,0)=" "
SET LINE=LINE+1
+12 ;
ALLER ;now the allergies
+1 IF ^XMB("NETNAME")["CMOP"
GOTO INTER
+2 ;skip allergies for CMOPs
+3 KILL ^TMP($JOB)
+4 SET PSNFREE=$ORDER(^GMRD(120.82,"B","OTHER ALLERGY/ADVERSE REACTION",0))_";GMRD(120,82,"
+5 SET PSNDA=0
FOR
SET PSNDA=$ORDER(^GMR(120.8,PSNDA))
if 'PSNDA
QUIT
SET PSNPAT=+^(PSNDA,0)
SET PSNPAT=$PIECE(^DPT(PSNPAT,0),"^")
Begin DoDot:1
+6 SET PSNI=$PIECE(^GMR(120.8,PSNDA,0),"^",3)
IF PSNI["PS(50.416"
IF '$DATA(^PS(50.416,+PSNI,0))
SET $PIECE(^GMR(120.8,PSNDA,0),"^",3)=PSNFREE
SET DIE="^GMR(120.8,"
SET DA=PSNDA
SET DR="22////1;23////"_$$NOW^XLFDT_";24////"_DUZ_";"
DO ^DIE
SET ^TMP($JOB,2,PSNPAT)=""
Begin DoDot:2
+7 DO ADCOM^GMRAFX(PSNDA,"E","Marked entered in error by patch PSN*4*107")
End DoDot:2
+8 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
+9 SET PSNK=0
FOR
SET PSNK=$ORDER(^GMR(120.8,PSNDA,2,PSNK))
if 'PSNK
QUIT
SET PSNI=^(PSNK,0)
Begin DoDot:2
+10 IF '$DATA(^PS(50.416,PSNI,0))
SET DA(1)=PSNDA
SET DA=PSNK
SET DIE="^GMR(120.8,DA(1),2,"
SET DR=".01///@"
DO ^DIE
SET ^TMP($JOB,2,PSNPAT)=""
QUIT
+11 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
+12 ;
+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",J,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 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
+18 IF '$DATA(^TMP($JOB,2))
SET ^TMP("PSN",$JOB,LINE,0)="none found"
SET LINE=LINE+1
+19 SET NA=""
FOR
SET NA=$ORDER(^TMP($JOB,2,NA))
if NA=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=NA
SET LINE=LINE+1
+20 ;
INTER KILL PSN1
SET PSN2=$PIECE($TEXT(LIST),";",3)
FOR J=1:1:$LENGTH(PSN2,"^")-1
SET PSN1($PIECE(PSN2,"^",J))=""
+1 KILL ^TMP($JOB)
SET DA=0
FOR
SET DA=$ORDER(^PS(56,DA))
if 'DA
QUIT
if DA>14999
QUIT
IF '$DATA(PSN1(DA))
SET X=^(DA,0)
SET OLD=$PIECE(X,"^")
SET PSNI1=$PIECE(X,"^",2)
SET PSNI2=$PIECE(X,"^",3)
KILL PSN,PSNN
Begin DoDot:1
+2 SET PSN($PIECE(^PS(50.416,PSNI1,0),"^"))=""
SET PSN($PIECE(^PS(50.416,PSNI2,0),"^"))=""
SET PSNN=$ORDER(PSN(""))_"/"_$ORDER(PSN($ORDER(PSN(""))))
IF PSNN'=OLD
SET ^TMP($JOB,OLD_"^"_DA)=""
End DoDot:1
+3 FOR J=1:1
SET X=$PIECE($TEXT(TEXT6+J),";",3,300)
if X=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=X
SET LINE=LINE+1
+4 IF '$DATA(^TMP($JOB))
SET ^TMP("PSN",$JOB,LINE,0)="none found"
SET LINE=LINE+1
+5 SET NA=""
FOR
SET NA=$ORDER(^TMP($JOB,NA))
if NA=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=$PIECE(NA,"^",2)
SET $EXTRACT(^(0),12)=$PIECE(NA,"^")
SET LINE=LINE+1
SENDIT ;
+1 SET XMSUB="INGREDIENTS AND INTERACTIONS DELETED"
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
+3 KILL DA,DIE,DIK,DR,J,K,LINE,NA,OLD,PSN,PSN1,PSN11,PSN2,PSN21,PSNA1,PSNA2,PSNDA,PSNFREE,PSNI,PSNI1,PSNI2,PSNAPT,PSNPSNI1,PSNK,PSNX,PSNN,PSNN1,PSNQ,X,XMDUZ,XMSUB,XMTEXT,XMY,^TMP($JOB),^TMP("PSN",$JOB)
+4 QUIT
TEXT ;
+1 ;;The following locally added ingredients have been deleted from the
+2 ;;INGREDIENTS file (#50.416).
+3 ;;
+4 ;
TEXT1 ;
+1 ;;============================================================================
+2 ;;
+3 ;;The following locally added interactions have been deleted from the
+4 ;;DRUG INTERACTIONS file (#56) because they check for ingredients other
+5 ;;than those indicated by the name.
+6 ;;
+7 ;;
+8 ;
+9 ;;
TEXT2 ;
+1 ;;============================================================================
+2 ;;
+3 ;;The following locally added interactions have been deleted from the
+4 ;;DRUG INTERACTIONS file (#56) because they involve locally entered
+5 ;;ingredients which have been deleted.
+6 ;;
+7 ;;
+8 ;
TEXT2A ;
+1 ;;========================================================================
+2 ;;
+3 ;;The following locally added interactions have been edited because they
+4 ;;involved ingredients that are not primary ingredients.
+5 ;;
+6 ;;
+7 ;;
+8 ;
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 ;;
TEXT5 ;
+1 ;;
+2 ;;========================================================================
+3 ;;The patient allergy entries for the listed patients were created with
+4 ;;locally added ingredients. Locally added ingredients are not supported
+5 ;;by the software and the allergies have been updated to 'entered in error'.
+6 ;;The patient allergy entry should be reviewed.
+7 ;;
+8 ;
TEXT6 ;
+1 ;;
+2 ;;========================================================================
+3 ;;
+4 ;;The following nationally entered interactions have a discrepancy
+5 ;;between the name and the ingredients. Please submit a remedy ticket
+6 ;;and attach the information in this section so that the proper cleanup
+7 ;;can be done.
+8 ;;
+9 ;;IEN Interaction
+10 ;;
+11 ;
LIST ;;2084^2085^2086^2087^2088^2089^2090^2091^2092^2093^2094^2095^2096^2136^2237^2238^2239^2244^2289^
