PSN4P406 ;ALB/HW-Pre Install Patients with Inactive Ingredients as Causative Agents Report ; 8/14/14 4:03pm
;;4.0;NATIONAL DRUG FILE;**406**; 30 Oct 98;Build 7
; This routine uses the following IAs:
; #5843 - Read file 120.8 (controlled)
; #10061 - DEM^VADPT (supported)
; #10070 - ^XMD (supported)
Q ;Must be called at entry point
;Only looking for patients that are not deceased and
;where the inactive ingredient has been entered directly as a causative agent.
EN N PSNIEN,PSNINING,DFN,PSNCOUNT,DIFROM
K ^TMP("PSN",$J)
S PSNIEN=0,PSNCOUNT=0
D BMES^XPDUTL("Patients with Inactive Ingredient(s) Entered as Causative Agent(s)")
S ^TMP("PSN",$J,0)=" "_"Patients with Inactive Ingredient(s) Entered as Causative Agent(s)"
D MES^XPDUTL(" ")
D BMES^XPDUTL("DFN Inactive Ingredient to be Corrected ")
D BMES^XPDUTL(" ")
S ^TMP("PSN",$J,1)="DFN"_" "_"Inactive Ingredient to be Corrected "
F S PSNIEN=$O(^PS(50.416,PSNIEN)) Q:PSNIEN'>0 D
.I $G(^PS(50.416,PSNIEN,2))'>0 Q
.S PSNINING=$P(^PS(50.416,PSNIEN,0),"^") D FINDPAL(PSNINING,PSNIEN,.PSNCOUNT) Q
I PSNCOUNT<1 D
.D BMES^XPDUTL("No patient allergies with inactive ingredient as causative agent found")
.D MES^XPDUTL(" ")
.S ^TMP("PSN",$J,PSNCOUNT+2)="No patient allergies with inactive ingredient as causative agent found"
S XMSUB="Patient Allergies with Inactive Ingredients",XMTEXT="^TMP(""PSN"",$J,",XMY(DUZ)=""
D BMES^XPDUTL(" ")
D BMES^XPDUTL(" ")
D ^XMD K XMSUB,XMTEXT,XMY
Q
FINDPAL(PSNINING,PSNIEN,PSNCOUNT) ;Search C cross-ref for matching ingr name to get 120.8 data
N PSNPALR,PSNOUT,PSNPIEN,PSNX,PSNDGMAL,DFN,VADM,VAERR,VA,PSNSP1,PSNSPN1
D FIND^DIC(120.8,"","@;.01EI;.02;1I;22I","X",PSNINING,"","C","","","PSNPALR($J)","PSNOUT($J)")
I $D(PSNOUT($J,"DIERR"))>0 D
.S ^XTMP("PSN4P406",0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^Errors matching ingredients"
.M ^XTMP("PSN4P406")=PSNOUT($J)
.D MES^XPDUTL("Error matching ingredient name")
.S PSNCOUNT=PSNCOUNT+1,^TMP("PSN",$J,PSNCOUNT+2)="Error: Problem matching ingredient name"
;Check if entered in error and if GMR Allergy value matches
I $P($G(PSNPALR($J,"DILIST",0)),"^")<1 Q
S PSNPIEN=0
F S PSNPIEN=$O(PSNPALR($J,"DILIST",2,PSNPIEN)) Q:PSNPIEN'>0 D
.I PSNPALR($J,"DILIST","ID",PSNPIEN,22)>0 Q
.S PSNDGMAL=PSNPALR($J,"DILIST","ID",PSNPIEN,1)
.I PSNDGMAL'["PS(50.416" Q
.I +PSNDGMAL'=PSNIEN Q
.;Check if patient has DATE OF DEATH
.S DFN=PSNPALR($J,"DILIST","ID",PSNPIEN,.01,"I")
.D DEM^VADPT
.I VAERR D Q
..D MES^XPDUTL("Error: Problem retrieving demographic data for DFN: "_DFN)
..S PSNCOUNT=PSNCOUNT+1,^TMP("PSN",$J,PSNCOUNT+2)="Error: Problem retrieving demographic data for DFN: "_DFN
.I VADM(6)<1 D
..S PSNSP1=" "
..S PSNSPN1=30-$L(DFN) F PSNX=1:1:PSNSPN1 S PSNSP1=PSNSP1_" "
..S PSNCOUNT=PSNCOUNT+1,^TMP("PSN",$J,PSNCOUNT+2)=DFN_PSNSP1_PSNINING
..D MES^XPDUTL(DFN_PSNSP1_PSNINING)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSN4P406 3401 printed Sep 23, 2025@19:58:17 Page 2
PSN4P406 ;ALB/HW-Pre Install Patients with Inactive Ingredients as Causative Agents Report ; 8/14/14 4:03pm
+1 ;;4.0;NATIONAL DRUG FILE;**406**; 30 Oct 98;Build 7
+2 ; This routine uses the following IAs:
+3 ; #5843 - Read file 120.8 (controlled)
+4 ; #10061 - DEM^VADPT (supported)
+5 ; #10070 - ^XMD (supported)
+6 ;Must be called at entry point
QUIT
+7 ;Only looking for patients that are not deceased and
+8 ;where the inactive ingredient has been entered directly as a causative agent.
EN NEW PSNIEN,PSNINING,DFN,PSNCOUNT,DIFROM
+1 KILL ^TMP("PSN",$JOB)
+2 SET PSNIEN=0
SET PSNCOUNT=0
+3 DO BMES^XPDUTL("Patients with Inactive Ingredient(s) Entered as Causative Agent(s)")
+4 SET ^TMP("PSN",$JOB,0)=" "_"Patients with Inactive Ingredient(s) Entered as Causative Agent(s)"
+5 DO MES^XPDUTL(" ")
+6 DO BMES^XPDUTL("DFN Inactive Ingredient to be Corrected ")
+7 DO BMES^XPDUTL(" ")
+8 SET ^TMP("PSN",$JOB,1)="DFN"_" "_"Inactive Ingredient to be Corrected "
+9 FOR
SET PSNIEN=$ORDER(^PS(50.416,PSNIEN))
if PSNIEN'>0
QUIT
Begin DoDot:1
+10 IF $GET(^PS(50.416,PSNIEN,2))'>0
QUIT
+11 SET PSNINING=$PIECE(^PS(50.416,PSNIEN,0),"^")
DO FINDPAL(PSNINING,PSNIEN,.PSNCOUNT)
QUIT
End DoDot:1
+12 IF PSNCOUNT<1
Begin DoDot:1
+13 DO BMES^XPDUTL("No patient allergies with inactive ingredient as causative agent found")
+14 DO MES^XPDUTL(" ")
+15 SET ^TMP("PSN",$JOB,PSNCOUNT+2)="No patient allergies with inactive ingredient as causative agent found"
End DoDot:1
+16 SET XMSUB="Patient Allergies with Inactive Ingredients"
SET XMTEXT="^TMP(""PSN"",$J,"
SET XMY(DUZ)=""
+17 DO BMES^XPDUTL(" ")
+18 DO BMES^XPDUTL(" ")
+19 DO ^XMD
KILL XMSUB,XMTEXT,XMY
+20 QUIT
FINDPAL(PSNINING,PSNIEN,PSNCOUNT) ;Search C cross-ref for matching ingr name to get 120.8 data
+1 NEW PSNPALR,PSNOUT,PSNPIEN,PSNX,PSNDGMAL,DFN,VADM,VAERR,VA,PSNSP1,PSNSPN1
+2 DO FIND^DIC(120.8,"","@;.01EI;.02;1I;22I","X",PSNINING,"","C","","","PSNPALR($J)","PSNOUT($J)")
+3 IF $DATA(PSNOUT($JOB,"DIERR"))>0
Begin DoDot:1
+4 SET ^XTMP("PSN4P406",0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^Errors matching ingredients"
+5 MERGE ^XTMP("PSN4P406")=PSNOUT($JOB)
+6 DO MES^XPDUTL("Error matching ingredient name")
+7 SET PSNCOUNT=PSNCOUNT+1
SET ^TMP("PSN",$JOB,PSNCOUNT+2)="Error: Problem matching ingredient name"
End DoDot:1
+8 ;Check if entered in error and if GMR Allergy value matches
+9 IF $PIECE($GET(PSNPALR($JOB,"DILIST",0)),"^")<1
QUIT
+10 SET PSNPIEN=0
+11 FOR
SET PSNPIEN=$ORDER(PSNPALR($JOB,"DILIST",2,PSNPIEN))
if PSNPIEN'>0
QUIT
Begin DoDot:1
+12 IF PSNPALR($JOB,"DILIST","ID",PSNPIEN,22)>0
QUIT
+13 SET PSNDGMAL=PSNPALR($JOB,"DILIST","ID",PSNPIEN,1)
+14 IF PSNDGMAL'["PS(50.416"
QUIT
+15 IF +PSNDGMAL'=PSNIEN
QUIT
+16 ;Check if patient has DATE OF DEATH
+17 SET DFN=PSNPALR($JOB,"DILIST","ID",PSNPIEN,.01,"I")
+18 DO DEM^VADPT
+19 IF VAERR
Begin DoDot:2
+20 DO MES^XPDUTL("Error: Problem retrieving demographic data for DFN: "_DFN)
+21 SET PSNCOUNT=PSNCOUNT+1
SET ^TMP("PSN",$JOB,PSNCOUNT+2)="Error: Problem retrieving demographic data for DFN: "_DFN
End DoDot:2
QUIT
+22 IF VADM(6)<1
Begin DoDot:2
+23 SET PSNSP1=" "
+24 SET PSNSPN1=30-$LENGTH(DFN)
FOR PSNX=1:1:PSNSPN1
SET PSNSP1=PSNSP1_" "
+25 SET PSNCOUNT=PSNCOUNT+1
SET ^TMP("PSN",$JOB,PSNCOUNT+2)=DFN_PSNSP1_PSNINING
+26 DO MES^XPDUTL(DFN_PSNSP1_PSNINING)
End DoDot:2
End DoDot:1
