- 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 Feb 18, 2025@23:49:55 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^