- 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 Mar 13, 2025@21:27:02 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
