PSN4P406.m

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 ---PSN4P406   3401     printed  Apr 09, 2024@21:25:40                                                                                                                                                                                                    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