Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSNCLING

PSNCLING.m

Go to the documentation of this file.
  1. PSNCLING ;BIR/DMA-clean up ingredients and interactions ; 19 Jan 2006 9:45 AM
  1. ;;4.0; NATIONAL DRUG FILE;**107**; 3O Oct 98
  1. ;
  1. ;Reference to ^GMRD(120.8 supported by DBIA# 2545
  1. ;Reference to ADCOM^GMRAFX supported by DBIA# 4783
  1. ;
  1. ;delete existing cross reference
  1. K ^PS(50.416,"P")
  1. ;and the entries
  1. ;
  1. ;following code generated by DIKCBLD
  1. N PSNXR,PSNRES,PSNOUT
  1. S PSNXR("FILE")=50.416
  1. S PSNXR("NAME")="P1"
  1. S PSNXR("TYPE")="MU"
  1. S PSNXR("USE")="LS"
  1. S PSNXR("EXECUTION")="R"
  1. S PSNXR("ACTIVITY")="IR"
  1. S PSNXR("SHORT DESCR")="CROSS REFERENCE ON PRIMARY INGREDIENT"
  1. S PSNXR("DESCR",1)=" "
  1. S PSNXR("SET")="I X2(1)'="""",X2(2)="""" S ^PS(50.416,""P"",X2(1),DA)="""""
  1. S PSNXR("KILL")="I X2(1)=""""!(X2(2)'="""")!(X1(1)'=X2(1)) K ^PS(50.416,""P"",X1(1),DA)"
  1. S PSNXR("WHOLE KILL")="K ^PS(50.416,""P"")"
  1. S PSNXR("VAL",1)=.01
  1. S PSNXR("VAL",1,"COLLATION")="F"
  1. S PSNXR("VAL",2)=2
  1. S PSNXR("VAL",2,"COLLATION")="F"
  1. D CREIXN^DDMOD(.PSNXR,"SW",.PSNRES,"PSNOUT")
  1. ;end of generated code
  1. ;
  1. 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
  1. K ^TMP($J),^TMP("PSN",$J)
  1. S DA=4254
  1. F S DA=$O(^PS(50.416,DA)) Q:'DA S X=$P(^(DA,0),"^"),^TMP($J,X)="",DIK="^PS(50.416," D ^DIK
  1. ;
  1. MESSAGE ;
  1. F LINE=1:1 S X=$P($T(TEXT+LINE),";",3,300) Q:X="" S ^TMP("PSN",$J,LINE,0)=X
  1. I '$D(^TMP($J)) S ^TMP("PSN",$J,LINE,0)="none found",LINE=LINE+1
  1. S NA="" F LINE=LINE:1 S NA=$O(^TMP($J,NA)) Q:NA="" S ^TMP("PSN",$J,LINE,0)=NA
  1. ;
  1. ;
  1. ;now the interactions
  1. K ^TMP($J)
  1. ;
  1. S DA=14999 F S DA=$O(^PS(56,DA)) Q:'DA S X=^(DA,0),OLD=$P(X,"^") K PSN,PSNN D
  1. .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
  1. .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
  1. ..S PSNN1=$P(PSNN,"/",2)_"/"_$P(PSNN,"/") I PSNN1=OLD S DIE="^PS(56,",DR=".01////"_PSNN D ^DIE Q
  1. ..S ^TMP($J,2,OLD)=PSNN,DIK="^PS(56," D ^DIK S PSNQ=1 Q
  1. .S X=$P(^PS(50.416,PSNI1,0),"^",2) I X S $P(^PS(56,DA,0),"^",2)=X,PSNI1=X
  1. .S X=$P(^PS(50.416,PSNI2,0),"^",2) I X S $P(^PS(56,DA,0),"^",3)=X,PSNI2=X
  1. .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
  1. ..I $O(^PS(56,"B",PSNN,0)),$O(^(0))'=DA S DIK="^PS(56," D ^DIK Q
  1. ..D ^DIE S ^TMP($J,3,OLD)=PSNN
  1. ;
  1. ;now the APD
  1. 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)=""
  1. ;now the interactions
  1. 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
  1. .S NA="" F S NA=$O(^PS(50.416,PSN1,1,"B",NA)) Q:NA="" S PSN1(NA)=""
  1. .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)=""
  1. .S NA="" F S NA=$O(^PS(50.416,PSN2,1,"B",NA)) Q:NA="" S PSN2(NA)=""
  1. .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)=""
  1. .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)=""
  1. ;
  1. MORE ;MESSAGE CONTINUED
  1. F J=1:1 S X=$P($T(TEXT1+J),";",3) Q:X="" S ^TMP("PSN",$J,LINE,0)=X,LINE=LINE+1
  1. I '$D(^TMP($J,2)) S ^TMP("PSN",$J,LINE,0)="none found" S LINE=LINE+1
  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
  1. ;
  1. ;
  1. F J=1:1 S X=$P($T(TEXT2+J),";",3) Q:X="" S ^TMP("PSN",$J,LINE,0)=X,LINE=LINE+1
  1. I $O(^TMP($J,1,""))="" S ^TMP("PSN",$J,LINE,0)="none found",LINE=LINE+1
  1. S NA="" F S NA=$O(^TMP($J,1,NA)) Q:NA="" S ^TMP("PSN",$J,LINE,0)=NA,LINE=LINE+1
  1. F J=1:1 S X=$P($T(TEXT2A+J),";",3) Q:X="" S ^TMP("PSN",$J,LINE,0)=X,LINE=LINE+1
  1. I $O(^TMP($J,3,""))="" S ^TMP("PSN",$J,LINE,0)="none found",LINE=LINE+1
  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
  1. ;
  1. ALLER ;now the allergies
  1. I ^XMB("NETNAME")["CMOP" G INTER
  1. ;skip allergies for CMOPs
  1. K ^TMP($J)
  1. S PSNFREE=$O(^GMRD(120.82,"B","OTHER ALLERGY/ADVERSE REACTION",0))_";GMRD(120,82,"
  1. S PSNDA=0 F S PSNDA=$O(^GMR(120.8,PSNDA)) Q:'PSNDA S PSNPAT=+^(PSNDA,0),PSNPAT=$P(^DPT(PSNPAT,0),"^") D
  1. .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
  1. ..D ADCOM^GMRAFX(PSNDA,"E","Marked entered in error by patch PSN*4*107")
  1. .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
  1. .S PSNK=0 F S PSNK=$O(^GMR(120.8,PSNDA,2,PSNK)) Q:'PSNK S PSNI=^(PSNK,0) D
  1. ..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
  1. ..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),"^"))=""
  1. ;
  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
  1. I '$D(^TMP($J,1)) S ^TMP("PSN",J,LINE,0)="none found",LINE=LINE+1
  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
  1. .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
  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
  1. I '$D(^TMP($J,2)) S ^TMP("PSN",$J,LINE,0)="none found",LINE=LINE+1
  1. S NA="" F S NA=$O(^TMP($J,2,NA)) Q:NA="" S ^TMP("PSN",$J,LINE,0)=NA,LINE=LINE+1
  1. ;
  1. INTER K PSN1 S PSN2=$P($T(LIST),";",3) F J=1:1:$L(PSN2,"^")-1 S PSN1($P(PSN2,"^",J))=""
  1. 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
  1. .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)=""
  1. F J=1:1 S X=$P($T(TEXT6+J),";",3,300) Q:X="" S ^TMP("PSN",$J,LINE,0)=X,LINE=LINE+1
  1. I '$D(^TMP($J)) S ^TMP("PSN",$J,LINE,0)="none found",LINE=LINE+1
  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
  1. SENDIT ;
  1. 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)=""
  1. N DIFROM D ^XMD
  1. 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)
  1. Q
  1. TEXT ;
  1. ;;The following locally added ingredients have been deleted from the
  1. ;;INGREDIENTS file (#50.416).
  1. ;;
  1. ;
  1. TEXT1 ;
  1. ;;============================================================================
  1. ;;
  1. ;;The following locally added interactions have been deleted from the
  1. ;;DRUG INTERACTIONS file (#56) because they check for ingredients other
  1. ;;than those indicated by the name.
  1. ;;
  1. ;;
  1. ;
  1. ;;
  1. TEXT2 ;
  1. ;;============================================================================
  1. ;;
  1. ;;The following locally added interactions have been deleted from the
  1. ;;DRUG INTERACTIONS file (#56) because they involve locally entered
  1. ;;ingredients which have been deleted.
  1. ;;
  1. ;;
  1. ;
  1. TEXT2A ;
  1. ;;========================================================================
  1. ;;
  1. ;;The following locally added interactions have been edited because they
  1. ;;involved ingredients that are not primary ingredients.
  1. ;;
  1. ;;
  1. ;;
  1. ;
  1. TEXT3 ;
  1. ;;
  1. ;;============================================================================
  1. ;;Allergy information for the following patients has been changed.
  1. ;;
  1. ;;The allergy for the listed patients was created with a non-primary
  1. ;;ingredient. These have been updated to replace the non-primary
  1. ;;ingredient with the proper primary ingredient.
  1. ;;
  1. TEXT5 ;
  1. ;;
  1. ;;========================================================================
  1. ;;The patient allergy entries for the listed patients were created with
  1. ;;locally added ingredients. Locally added ingredients are not supported
  1. ;;by the software and the allergies have been updated to 'entered in error'.
  1. ;;The patient allergy entry should be reviewed.
  1. ;;
  1. ;
  1. TEXT6 ;
  1. ;;
  1. ;;========================================================================
  1. ;;
  1. ;;The following nationally entered interactions have a discrepancy
  1. ;;between the name and the ingredients. Please submit a remedy ticket
  1. ;;and attach the information in this section so that the proper cleanup
  1. ;;can be done.
  1. ;;
  1. ;;IEN Interaction
  1. ;;
  1. ;
  1. LIST ;;2084^2085^2086^2087^2088^2089^2090^2091^2092^2093^2094^2095^2096^2136^2237^2238^2239^2244^2289^