PSAP56 ;VMP/PDW-DUPLICATE REMOVAL ;93/17/2006
;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**56**; 10/24/97
;;References to ^PSDRUG( are covered by DBIA #2095
EN ;
D EXIT
S VSN=0 F S VSN=$O(^PSDRUG("AVSN",VSN)) Q:VSN'>0 D VSN
D MAILMSG,EXIT
Q
VSN ;
S DRDA=0,RXCNT=0 F S DRDA=$O(^PSDRUG("AVSN",VSN,DRDA)) Q:DRDA'>0 D DRDA
Q
DRDA ;process drug:VSN
;SYN0(counter)=node, SYNIEN(counter)=SYDA
K SYN0,SYNIEN,SYNDUP,SYNDC,SYCNT
S SYDA=0 F S SYDA=$O(^PSDRUG("AVSN",VSN,DRDA,SYDA)) Q:SYDA'>0 D
. ; if more DRUG VSN decendents process the DRUG
.I +$O(^PSDRUG("AVSN",VSN,DRDA,SYDA)) D MORE
Q
MORE ;
K SYN0,SYNIEN,SYNDUP,SYNDC,SYCNT
S SYNIEN=0 F S SYNIEN=$O(^PSDRUG("AVSN",VSN,DRDA,SYNIEN)) Q:SYNIEN'>0 D
.S SYCNT=$G(SYCNT)+1,SYN0(SYCNT)=^PSDRUG(DRDA,1,SYNIEN,0),SYNIEN(SYCNT)=SYNIEN
.S SYDA=SYNIEN ; reset upper loop to end of VSNs
;
DUPS ;compare synonyms of the identical VSN/drug found
K SYNDUP
;pairs of divisions may have set the same drug with different DUOU, dups then on sereval DUOU
;FIND EXACT MATCHES, store pairs in SYNDUP(N1,N2)="", and DELETE ALL BUT FIRST
F N1=1:1:SYCNT-1 F N2=N1+1:1:SYCNT I SYN0(N1)=SYN0(N2) S SYNDUP(N1,N2)=""
I '$D(SYNDUP) Q
D DELETE
D LOGDUP
Q
DELETE ;
Q:'$D(SYNDUP)
S N1=0 F S N1=$O(SYNDUP(N1)) Q:N1'>0 D
. S N2=0 F S N2=$O(SYNDUP(N1,N2)) Q:N2'>0 D
. . K DIK S DA(1)=DRDA,DA=SYNIEN(N2),DIK="^PSDRUG("_DA(1)_",1," D ^DIK
. . K SYNDC(N2) ;if dup N2 is removed its NDC match to others needs to be removed
. . K SYNDUP(N2) ; if N2 has dups they will also have been picked up under N1 already
Q
LOGDUP ;
S DRGNM=$P(^PSDRUG(DRDA,0),U,1)
S SYDAL=0 F S SYDAL=$O(SYNDUP(SYDAL)) Q:SYDAL'>0 S ^TMP($J,"PSADUP",DRGNM,DRDA,SYNIEN(SYDAL))=0
Q
;SYN0(SYCNT)=^PSDRUG(DRDA,1,SYDA,0)
;SYNIEN(SYCNT)=SYDA
;S SYNDUP(N1,N2)=""
;S SYNDC(N1,N2)=""
MAILMSG ; generate mail message of duplicates deleted.
K ^TMP($J,"PSAMM")
N DIFROM
I $D(^TMP($J,"PSADUP")) I 1
E G NOMSG
S X="PSA*3*56 DELETE DUPLICATE SYNONYMS REPORT" D MMLN
S X="The following Drug-Synonyms have had identical synonyms removed from the drug." D MMLN
S X="" D TXT("Drug Name",1),TXT("DRG#,SYN#",43),TXT("NDC",53),TXT("VSN",68),MMLN
S DRGNM="" F S DRGNM=$O(^TMP($J,"PSADUP",DRGNM)) Q:DRGNM="" D DRIEN
S XMSUB="PSA*3*56 Delete Duplicate Drug Synonyms report"
S XMTEXT="^TMP($J,""PSAMM"",",XMDUZ="PSA*3*56 Post Init"
S XMY(DUZ)=""
D ^XMD
Q
DRIEN ;work the specific drug
S DRDA=0 F S DRDA=$O(^TMP($J,"PSADUP",DRGNM,DRDA)) Q:DRDA'>0 D SYNDR
Q
SYNDR ; work synonyms under a drug
S SYNDA=0 F S SYNDA=$O(^TMP($J,"PSADUP",DRGNM,DRDA,SYNDA)) Q:SYNDA'>0 D SYN
Q
SYN ;report the individual synonym that had duplicates deleted
K SYNFLD
;2-NDC'2 400-VSN'4 401-OU'5 402-PPOU'6 403-DUOU'7 404-PPDU'8
S SYN0=^PSDRUG(DRDA,1,SYNDA,0),X=SYN0,DA=SYNDA,DA(1)=DRDA,IENS=DA_","_DA(1)_","
S NDC=$P(X,U,2),VSN=$P(X,U,4),PPOU="PPOU: $"_$P(X,U,6),DUOU="DUOU: "_$P(X,U,7),PPDU="PPDU: $"_$P(X,U,8)
S OU="OU: "_$$GET1^DIQ(50.1,IENS,401),DA(1)=DRDA
S X="" D TXT(DRGNM,1),TXT(DRDA_","_SYNDA,43),TXT(NDC,53),TXT(VSN,68) D MMLN
S X="" D TXT(OU,1),TXT(PPOU,15),TXT(DUOU,45),TXT(PPDU,60) D MMLN
Q
MMLN S MMLC=+$G(MMLC)+1 S ^TMP($J,"PSAMM",MMLC)=X Q
TXT(VAL,COL) S:'$D(X) X="" S X=$$SETSTR^VALM1(VAL,X,COL,$L(VAL)) Q
NOMSG ; report no duplicates found to remove.
S X="PSA*3*56 DELETE DUPLICATE SYNONYMS REPORT" D MMLN
S X=" " D MMLN
S X="There were no duplicate drug-synonyms found. No synonyms removed." D MMLN
S XMSUB="PSA*3*56 Delete Duplicate Drug Synonyms report"
S XMTEXT="^TMP($J,""PSAMM"",",XMDUZ="PSA*3*56 Post Init"
S XMY(DUZ)=""
D ^XMD
EXIT ;
K COL,DIK,DRDA,DRGNM,DUOU,IENS,MMLC,N1,N2,NDC,OU,PPDU,DDOU,RXCNT,SYCNT,SYDA,SYN0
K SYNDA,SYNDC,SYNDUP,SYNFLD,SYNIEN,SYN0,^TMP($J),VAL,VSN,PPOU,SYDAL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAP56 3825 printed Dec 13, 2024@01:50 Page 2
PSAP56 ;VMP/PDW-DUPLICATE REMOVAL ;93/17/2006
+1 ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**56**; 10/24/97
+2 ;;References to ^PSDRUG( are covered by DBIA #2095
EN ;
+1 DO EXIT
+2 SET VSN=0
FOR
SET VSN=$ORDER(^PSDRUG("AVSN",VSN))
if VSN'>0
QUIT
DO VSN
+3 DO MAILMSG
DO EXIT
+4 QUIT
VSN ;
+1 SET DRDA=0
SET RXCNT=0
FOR
SET DRDA=$ORDER(^PSDRUG("AVSN",VSN,DRDA))
if DRDA'>0
QUIT
DO DRDA
+2 QUIT
DRDA ;process drug:VSN
+1 ;SYN0(counter)=node, SYNIEN(counter)=SYDA
+2 KILL SYN0,SYNIEN,SYNDUP,SYNDC,SYCNT
+3 SET SYDA=0
FOR
SET SYDA=$ORDER(^PSDRUG("AVSN",VSN,DRDA,SYDA))
if SYDA'>0
QUIT
Begin DoDot:1
+4 ; if more DRUG VSN decendents process the DRUG
+5 IF +$ORDER(^PSDRUG("AVSN",VSN,DRDA,SYDA))
DO MORE
End DoDot:1
+6 QUIT
MORE ;
+1 KILL SYN0,SYNIEN,SYNDUP,SYNDC,SYCNT
+2 SET SYNIEN=0
FOR
SET SYNIEN=$ORDER(^PSDRUG("AVSN",VSN,DRDA,SYNIEN))
if SYNIEN'>0
QUIT
Begin DoDot:1
+3 SET SYCNT=$GET(SYCNT)+1
SET SYN0(SYCNT)=^PSDRUG(DRDA,1,SYNIEN,0)
SET SYNIEN(SYCNT)=SYNIEN
+4 ; reset upper loop to end of VSNs
SET SYDA=SYNIEN
End DoDot:1
+5 ;
DUPS ;compare synonyms of the identical VSN/drug found
+1 KILL SYNDUP
+2 ;pairs of divisions may have set the same drug with different DUOU, dups then on sereval DUOU
+3 ;FIND EXACT MATCHES, store pairs in SYNDUP(N1,N2)="", and DELETE ALL BUT FIRST
+4 FOR N1=1:1:SYCNT-1
FOR N2=N1+1:1:SYCNT
IF SYN0(N1)=SYN0(N2)
SET SYNDUP(N1,N2)=""
+5 IF '$DATA(SYNDUP)
QUIT
+6 DO DELETE
+7 DO LOGDUP
+8 QUIT
DELETE ;
+1 if '$DATA(SYNDUP)
QUIT
+2 SET N1=0
FOR
SET N1=$ORDER(SYNDUP(N1))
if N1'>0
QUIT
Begin DoDot:1
+3 SET N2=0
FOR
SET N2=$ORDER(SYNDUP(N1,N2))
if N2'>0
QUIT
Begin DoDot:2
+4 KILL DIK
SET DA(1)=DRDA
SET DA=SYNIEN(N2)
SET DIK="^PSDRUG("_DA(1)_",1,"
DO ^DIK
+5 ;if dup N2 is removed its NDC match to others needs to be removed
KILL SYNDC(N2)
+6 ; if N2 has dups they will also have been picked up under N1 already
KILL SYNDUP(N2)
End DoDot:2
End DoDot:1
+7 QUIT
LOGDUP ;
+1 SET DRGNM=$PIECE(^PSDRUG(DRDA,0),U,1)
+2 SET SYDAL=0
FOR
SET SYDAL=$ORDER(SYNDUP(SYDAL))
if SYDAL'>0
QUIT
SET ^TMP($JOB,"PSADUP",DRGNM,DRDA,SYNIEN(SYDAL))=0
+3 QUIT
+4 ;SYN0(SYCNT)=^PSDRUG(DRDA,1,SYDA,0)
+5 ;SYNIEN(SYCNT)=SYDA
+6 ;S SYNDUP(N1,N2)=""
+7 ;S SYNDC(N1,N2)=""
MAILMSG ; generate mail message of duplicates deleted.
+1 KILL ^TMP($JOB,"PSAMM")
+2 NEW DIFROM
+3 IF $DATA(^TMP($JOB,"PSADUP"))
IF 1
+4 IF '$TEST
GOTO NOMSG
+5 SET X="PSA*3*56 DELETE DUPLICATE SYNONYMS REPORT"
DO MMLN
+6 SET X="The following Drug-Synonyms have had identical synonyms removed from the drug."
DO MMLN
+7 SET X=""
DO TXT("Drug Name",1)
DO TXT("DRG#,SYN#",43)
DO TXT("NDC",53)
DO TXT("VSN",68)
DO MMLN
+8 SET DRGNM=""
FOR
SET DRGNM=$ORDER(^TMP($JOB,"PSADUP",DRGNM))
if DRGNM=""
QUIT
DO DRIEN
+9 SET XMSUB="PSA*3*56 Delete Duplicate Drug Synonyms report"
+10 SET XMTEXT="^TMP($J,""PSAMM"","
SET XMDUZ="PSA*3*56 Post Init"
+11 SET XMY(DUZ)=""
+12 DO ^XMD
+13 QUIT
DRIEN ;work the specific drug
+1 SET DRDA=0
FOR
SET DRDA=$ORDER(^TMP($JOB,"PSADUP",DRGNM,DRDA))
if DRDA'>0
QUIT
DO SYNDR
+2 QUIT
SYNDR ; work synonyms under a drug
+1 SET SYNDA=0
FOR
SET SYNDA=$ORDER(^TMP($JOB,"PSADUP",DRGNM,DRDA,SYNDA))
if SYNDA'>0
QUIT
DO SYN
+2 QUIT
SYN ;report the individual synonym that had duplicates deleted
+1 KILL SYNFLD
+2 ;2-NDC'2 400-VSN'4 401-OU'5 402-PPOU'6 403-DUOU'7 404-PPDU'8
+3 SET SYN0=^PSDRUG(DRDA,1,SYNDA,0)
SET X=SYN0
SET DA=SYNDA
SET DA(1)=DRDA
SET IENS=DA_","_DA(1)_","
+4 SET NDC=$PIECE(X,U,2)
SET VSN=$PIECE(X,U,4)
SET PPOU="PPOU: $"_$PIECE(X,U,6)
SET DUOU="DUOU: "_$PIECE(X,U,7)
SET PPDU="PPDU: $"_$PIECE(X,U,8)
+5 SET OU="OU: "_$$GET1^DIQ(50.1,IENS,401)
SET DA(1)=DRDA
+6 SET X=""
DO TXT(DRGNM,1)
DO TXT(DRDA_","_SYNDA,43)
DO TXT(NDC,53)
DO TXT(VSN,68)
DO MMLN
+7 SET X=""
DO TXT(OU,1)
DO TXT(PPOU,15)
DO TXT(DUOU,45)
DO TXT(PPDU,60)
DO MMLN
+8 QUIT
MMLN SET MMLC=+$GET(MMLC)+1
SET ^TMP($JOB,"PSAMM",MMLC)=X
QUIT
TXT(VAL,COL) if '$DATA(X)
SET X=""
SET X=$$SETSTR^VALM1(VAL,X,COL,$LENGTH(VAL))
QUIT
NOMSG ; report no duplicates found to remove.
+1 SET X="PSA*3*56 DELETE DUPLICATE SYNONYMS REPORT"
DO MMLN
+2 SET X=" "
DO MMLN
+3 SET X="There were no duplicate drug-synonyms found. No synonyms removed."
DO MMLN
+4 SET XMSUB="PSA*3*56 Delete Duplicate Drug Synonyms report"
+5 SET XMTEXT="^TMP($J,""PSAMM"","
SET XMDUZ="PSA*3*56 Post Init"
+6 SET XMY(DUZ)=""
+7 DO ^XMD
EXIT ;
+1 KILL COL,DIK,DRDA,DRGNM,DUOU,IENS,MMLC,N1,N2,NDC,OU,PPDU,DDOU,RXCNT,SYCNT,SYDA,SYN0
+2 KILL SYNDA,SYNDC,SYNDUP,SYNFLD,SYNIEN,SYN0,^TMP($JOB),VAL,VSN,PPOU,SYDAL
+3 QUIT
