Routine: PSN441P

PSN441P ;BIR/HW-Post install routine to update Trade Name allergies - Class; 29 June 2015  3:18 PM

 ;;4.0;NATIONAL DRUG FILE;**441**; 30 Oct 98;Build 15

 ;Reference to UPDATE^GMRAUTL2 supported by DBIA #4667

 ;This routine will update patient allergies with a Trade Name in the Reactant field

 ;based on the VA Generic and VA Drug Class(es) provided

EN ;Call at entry point

 N PSNPRIEN,PSNTNCNT,PSNGIEN,PSNCLASS,PSNX,PSNDONTK,PSNVAPRD,MSG,PSNTRNAM,PSNDCIEN,XPDIDTOT

 S XPDIDTOT=63

 K ^TMP("PSNMSG",$J),^TMP("PSN441P",$J)

 S ^TMP("PSNMSG",$J,1,0)="Number of Patient Allergy entries by VA DRUG CLASS:"

 S ^TMP("PSNMSG",$J,2,0)=" "

 S ^TMP("PSNMSG",$J,3,0)="Before update:"

 S ^TMP("PSNMSG",$J,4,0)="CN103 - NON-OPIOID ANALGESICS:                         "_$$CNT("CN103")

 S ^TMP("PSNMSG",$J,5,0)="CN101 - OPIOID ANALGESICS:                             "_$$CNT("CN101")

 S ^TMP("PSNMSG",$J,6,0)=" "

 S ^TMP("PSNMSG",$J,7,0)="CN400 - ANTICONVULSANTS:                               "_$$CNT("CN400")

 S ^TMP("PSNMSG",$J,8,0)="CN302 - BENZODIAZEPINE DERIVATIVE SEDATIVES/HYPNOTICS: "_$$CNT("CN302")

 S PSNTNCNT=0

 S PSNVAGEN=3283,PSNOCL=72,PSNNCL=73 D UPDATE(PSNVAGEN,PSNOCL,PSNNCL,.PSNTNCNT) ;TRAMADOL (72 is CN103, 73 is CN101)

 S PSNVAGEN=4924,PSNOCL=72,PSNNCL=73 D UPDATE(PSNVAGEN,PSNOCL,PSNNCL,.PSNTNCNT) ;TRAMADOL/ACETAMINOPHEN (72 is CN103, 73 is CN101)

 S PSNVAGEN=3743,PSNOCL=72,PSNNCL=73 D UPDATE(PSNVAGEN,PSNOCL,PSNNCL,.PSNTNCNT) ;ACETAMINOPHEN/TRAMADOL (72 is CN103, 73 is CN101)

 S PSNVAGEN=161,PSNOCL=84,PSNNCL=83 D UPDATE(PSNVAGEN,PSNOCL,PSNNCL,.PSNTNCNT) ;CLONAZEPAM (84 is CN400, 83 is CN302)

 S PSNVAGEN=167,PSNOCL=84,PSNNCL=83 D UPDATE(PSNVAGEN,PSNOCL,PSNNCL,.PSNTNCNT) ;DIAZEPAM (84 is CN400, 83 is CN302)

 K ^TMP("PSN441P",$J)

 S ^TMP("PSNMSG",$J,9,0)=" "

 S ^TMP("PSNMSG",$J,10,0)=" "

 S ^TMP("PSNMSG",$J,11,0)="After update:"

 S ^TMP("PSNMSG",$J,12,0)="CN103 - NON-OPIOID ANALGESICS:                         "_$$CNT("CN103")

 S ^TMP("PSNMSG",$J,13,0)="CN101 - OPIOID ANALGESICS:                             "_$$CNT("CN101")

 S ^TMP("PSNMSG",$J,14,0)=" "

 S ^TMP("PSNMSG",$J,15,0)="CN400 - ANTICONVULSANTS:                               "_$$CNT("CN400")

 S ^TMP("PSNMSG",$J,16,0)="CN302 - BENZODIAZEPINE DERIVATIVE SEDATIVES/HYPNOTICS: "_$$CNT("CN302")

 K PSNVAGEN,PSNOCL,PSNNCL

CNT(PSNCLASS) ;Count the number of Patient Allergy entries for a specific class

 N PSNA,PSNB,PSNC,PSNCNT

 S (PSNA,PSNB,PSNC,PSNCNT)=0

 F  S PSNA=$O(^GMR(120.8,"APC",PSNA)) Q:'PSNA  D

 .F  S PSNB=$O(^GMR(120.8,"APC",PSNA,PSNCLASS,PSNB)) Q:'PSNB  D

 ..F  S PSNC=$O(^GMR(120.8,"APC",PSNA,PSNCLASS,PSNB,PSNC)) Q:'PSNC  D

 ...S PSNCNT=PSNCNT+1

 Q PSNCNT

UPDATE(PSNVAGEN,PSNOCL,PSNNCL,PSNTNCNT) ;Find Trade Names and update Allergies

 N CLASS

 S CLASS("D",PSNOCL)="" ;IEN of class to be deleted

 S CLASS("A",PSNNCL)="" ;IEN of class to be added

 S PSNPRIEN=0

 F  S PSNPRIEN=$O(^PSNDF(50.68,PSNPRIEN)) Q:'PSNPRIEN  D

 .I +$P($G(^PSNDF(50.68,PSNPRIEN,0)),"^",2)'=PSNVAGEN Q

 .I +$G(^PSNDF(50.68,PSNPRIEN,3))'=PSNNCL Q

 .S PSNGIEN=$P(^PSNDF(50.68,PSNPRIEN,0),"^",2)

 .S PSNDCIEN=0

 .F  S PSNDCIEN=$O(^PSNDF(50.68,"ANDC",PSNPRIEN,PSNDCIEN)) Q:'PSNDCIEN  D

 ..S PSNTRNAM=$P($G(^PSNDF(50.67,PSNDCIEN,0)),"^",5)

 ..I $D(^TMP("PSN441P",$J,PSNGIEN,PSNTRNAM)) Q

 ..S PSNX=PSNGIEN_";PSNDF(50.6,^"_PSNTRNAM

 ..S PSNDONTK=0,PSNVAPRD=0

 ..F  S PSNVAPRD=$O(^PSNDF(50.6,"APRO",PSNGIEN,PSNVAPRD)) Q:'PSNVAPRD  D

 ...I $P(^PSNDF(50.68,PSNVAPRD,3),"^")=PSNOCL S PSNDONTK=1

 ..I PSNDONTK K CLASS("D")

 ..S PSNTNCNT=PSNTNCNT+1

 ..D BMES^XPDUTL("Updating Patient Allergies for "_PSNTRNAM)

 ..I $T(UPDATE^GMRAUTL2)]"" D UPDATE^GMRAUTL2(PSNX,,.CLASS)

 ..S ^TMP("PSN441P",$J,PSNGIEN,PSNTRNAM)=""

 ..D UPDATE^XPDID(PSNTNCNT)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSN441P   3788     printed  Apr 09, 2024@21:23:45                                                                                                                                                                                                     Page 2

PSN441P   ;BIR/HW-Post install routine to update Trade Name allergies - Class; 29 June 2015  3:18 PM

 +1       ;;4.0;NATIONAL DRUG FILE;**441**; 30 Oct 98;Build 15

 +2       ;Reference to UPDATE^GMRAUTL2 supported by DBIA #4667

 +3       ;This routine will update patient allergies with a Trade Name in the Reactant field

 +4       ;based on the VA Generic and VA Drug Class(es) provided

 +5        QUIT

EN        ;Call at entry point

 +1        NEW PSNPRIEN,PSNTNCNT,PSNGIEN,PSNCLASS,PSNX,PSNDONTK,PSNVAPRD,MSG,PSNTRNAM,PSNDCIEN,XPDIDTOT

 +2        SET XPDIDTOT=63

 +3        KILL ^TMP("PSNMSG",$JOB),^TMP("PSN441P",$JOB)

 +4        SET ^TMP("PSNMSG",$JOB,1,0)="Number of Patient Allergy entries by VA DRUG CLASS:"

 +5        SET ^TMP("PSNMSG",$JOB,2,0)=" "

 +6        SET ^TMP("PSNMSG",$JOB,3,0)="Before update:"

 +7        SET ^TMP("PSNMSG",$JOB,4,0)="CN103 - NON-OPIOID ANALGESICS:                         "_$$CNT("CN103")

 +8        SET ^TMP("PSNMSG",$JOB,5,0)="CN101 - OPIOID ANALGESICS:                             "_$$CNT("CN101")

 +9        SET ^TMP("PSNMSG",$JOB,6,0)=" "

 +10       SET ^TMP("PSNMSG",$JOB,7,0)="CN400 - ANTICONVULSANTS:                               "_$$CNT("CN400")

 +11       SET ^TMP("PSNMSG",$JOB,8,0)="CN302 - BENZODIAZEPINE DERIVATIVE SEDATIVES/HYPNOTICS: "_$$CNT("CN302")

 +12       SET PSNTNCNT=0

 +13      ;TRAMADOL (72 is CN103, 73 is CN101)

           SET PSNVAGEN=3283

           SET PSNOCL=72

           SET PSNNCL=73

           DO UPDATE(PSNVAGEN,PSNOCL,PSNNCL,.PSNTNCNT)

 +14      ;TRAMADOL/ACETAMINOPHEN (72 is CN103, 73 is CN101)

           SET PSNVAGEN=4924

           SET PSNOCL=72

           SET PSNNCL=73

           DO UPDATE(PSNVAGEN,PSNOCL,PSNNCL,.PSNTNCNT)

 +15      ;ACETAMINOPHEN/TRAMADOL (72 is CN103, 73 is CN101)

           SET PSNVAGEN=3743

           SET PSNOCL=72

           SET PSNNCL=73

           DO UPDATE(PSNVAGEN,PSNOCL,PSNNCL,.PSNTNCNT)

 +16      ;CLONAZEPAM (84 is CN400, 83 is CN302)

           SET PSNVAGEN=161

           SET PSNOCL=84

           SET PSNNCL=83

           DO UPDATE(PSNVAGEN,PSNOCL,PSNNCL,.PSNTNCNT)

 +17      ;DIAZEPAM (84 is CN400, 83 is CN302)

           SET PSNVAGEN=167

           SET PSNOCL=84

           SET PSNNCL=83

           DO UPDATE(PSNVAGEN,PSNOCL,PSNNCL,.PSNTNCNT)

 +18      ;

 +19       KILL ^TMP("PSN441P",$JOB)

 +20      ;

 +21       SET ^TMP("PSNMSG",$JOB,9,0)=" "

 +22       SET ^TMP("PSNMSG",$JOB,10,0)=" "

 +23       SET ^TMP("PSNMSG",$JOB,11,0)="After update:"

 +24       SET ^TMP("PSNMSG",$JOB,12,0)="CN103 - NON-OPIOID ANALGESICS:                         "_$$CNT("CN103")

 +25       SET ^TMP("PSNMSG",$JOB,13,0)="CN101 - OPIOID ANALGESICS:                             "_$$CNT("CN101")

 +26       SET ^TMP("PSNMSG",$JOB,14,0)=" "

 +27       SET ^TMP("PSNMSG",$JOB,15,0)="CN400 - ANTICONVULSANTS:                               "_$$CNT("CN400")

 +28       SET ^TMP("PSNMSG",$JOB,16,0)="CN302 - BENZODIAZEPINE DERIVATIVE SEDATIVES/HYPNOTICS: "_$$CNT("CN302")

 +29      ;

 +30       KILL PSNVAGEN,PSNOCL,PSNNCL

 +31       QUIT

 +32      ;

CNT(PSNCLASS) ;Count the number of Patient Allergy entries for a specific class

 +1        NEW PSNA,PSNB,PSNC,PSNCNT

 +2        SET (PSNA,PSNB,PSNC,PSNCNT)=0

 +3        FOR

               SET PSNA=$ORDER(^GMR(120.8,"APC",PSNA))

               if 'PSNA

                   QUIT

               Begin DoDot:1

 +4                FOR

                       SET PSNB=$ORDER(^GMR(120.8,"APC",PSNA,PSNCLASS,PSNB))

                       if 'PSNB

                           QUIT

                       Begin DoDot:2

 +5                        FOR

                               SET PSNC=$ORDER(^GMR(120.8,"APC",PSNA,PSNCLASS,PSNB,PSNC))

                               if 'PSNC

                                   QUIT

                               Begin DoDot:3

 +6                                SET PSNCNT=PSNCNT+1

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +7        QUIT PSNCNT

UPDATE(PSNVAGEN,PSNOCL,PSNNCL,PSNTNCNT) ;Find Trade Names and update Allergies

 +1        NEW CLASS

 +2       ;IEN of class to be deleted

           SET CLASS("D",PSNOCL)=""

 +3       ;IEN of class to be added

           SET CLASS("A",PSNNCL)=""

 +4        SET PSNPRIEN=0

 +5        FOR

               SET PSNPRIEN=$ORDER(^PSNDF(50.68,PSNPRIEN))

               if 'PSNPRIEN

                   QUIT

               Begin DoDot:1

 +6                IF +$PIECE($GET(^PSNDF(50.68,PSNPRIEN,0)),"^",2)'=PSNVAGEN

                       QUIT

 +7                IF +$GET(^PSNDF(50.68,PSNPRIEN,3))'=PSNNCL

                       QUIT

 +8                SET PSNGIEN=$PIECE(^PSNDF(50.68,PSNPRIEN,0),"^",2)

 +9                SET PSNDCIEN=0

 +10               FOR

                       SET PSNDCIEN=$ORDER(^PSNDF(50.68,"ANDC",PSNPRIEN,PSNDCIEN))

                       if 'PSNDCIEN

                           QUIT

                       Begin DoDot:2

 +11                       SET PSNTRNAM=$PIECE($GET(^PSNDF(50.67,PSNDCIEN,0)),"^",5)

 +12                       IF $DATA(^TMP("PSN441P",$JOB,PSNGIEN,PSNTRNAM))

                               QUIT

 +13                       SET PSNX=PSNGIEN_";PSNDF(50.6,^"_PSNTRNAM

 +14                       SET PSNDONTK=0

                           SET PSNVAPRD=0

 +15                       FOR

                               SET PSNVAPRD=$ORDER(^PSNDF(50.6,"APRO",PSNGIEN,PSNVAPRD))

                               if 'PSNVAPRD

                                   QUIT

                               Begin DoDot:3

 +16                               IF $PIECE(^PSNDF(50.68,PSNVAPRD,3),"^")=PSNOCL

                                       SET PSNDONTK=1

                               End DoDot:3

 +17                       IF PSNDONTK

                               KILL CLASS("D")

 +18                       SET PSNTNCNT=PSNTNCNT+1

 +19                       DO BMES^XPDUTL("Updating Patient Allergies for "_PSNTRNAM)

 +20                       IF $TEXT(UPDATE^GMRAUTL2)]""

                               DO UPDATE^GMRAUTL2(PSNX,,.CLASS)

 +21                       SET ^TMP("PSN441P",$JOB,PSNGIEN,PSNTRNAM)=""

 +22                       DO UPDATE^XPDID(PSNTNCNT)

                       End DoDot:2

               End DoDot:1

 +23       QUIT

PSN441P.m