- 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 Mar 13, 2025@20:54:39 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
