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
Q
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
Q
;
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)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSN441P 3788 printed Sep 23, 2025@19:57:23 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
