- PSNCLEAN ;BIR/DMA-clean up ingredients and interactions ; 19 Aug 2008 9:42 AM
- ;;4.0; NATIONAL DRUG FILE;**117,176**; 3O Oct 98;Build 14
- ;
- ;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.
- ;;
- PSNCLEAN ;BIR/DMA-clean up ingredients and interactions ; 19 Aug 2008 9:42 AM
- +1 ;;4.0; NATIONAL DRUG FILE;**117,176**; 3O Oct 98;Build 14
- +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 ;;
