LR421P.m

LR421P ;DALISC/SED - LR*5.2*421 PATCH POST INIT ROUTINE ;10 Oct 2013  4:49 PM

 ;;5.2;LAB SERVICE;**421**;Sep 27, 1994;Build 48

EN ;

 D BMES^XPDUTL("**** ICD 10 Remediation****")

 D BMES^XPDUTL("**Updating Emerging Pathogen File (69.5) with ICD Codes**")

CONVERT ;

 S LRCSYS="10D"

 I $T(^LREPICD)]"" D ICDCONVT^LREPICD

ICD ;Add the ICD codes to the file.

 ;SET CURRENT CODES TO APPROPRIATE CODE SYSTEMS

 N LRICDDA,LRICDCOD K LRPATH S LRPATH=0 F  S LRPATH=$O(^LAB(69.5,LRPATH)) Q:+LRPATH=0  D

 .I $D(^LAB(69.5,LRPATH,3)) S LRICDDA=0 F  S LRICDDA=$O(^LAB(69.5,LRPATH,3,LRICDDA)) Q:+LRICDDA=0  D

 ..K LRSET S LRICDCOD=+(^LAB(69.5,LRPATH,3,LRICDDA,0)),LRSET=$$CSI^ICDEX(80,LRICDCOD)

 ..S DIE="^LAB(69.5,"_LRPATH_",3,",DA=LRICDDA,DR="1////"_LRSET D ^DIE

 .Q

 ;LEISHMANIASIS   PATH14

 S LRPATH=14

 F LRICDNO=0,1,2,9 S LREPICDX="B55."_LRICDNO_" ",LRICDIEN=+$$CODEN^ICDEX(LREPICDX,80) D

 .Q:+LRICDIEN'>0

 .S LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDIEN,,)

 .Q:+LRTMP<0

 .D SETIC(LRICDIEN)

 ;MALARIA   PATH11

 S LRPATH=11

 F LREPICDX="B50.0 ","B50.8 ","B50.9 ","B51.0 ","B51.8 ","B51.9 ","B52.0 ","B52.8 ","B52.9 ","B53.0 ","B53.1 ","B53.8 ","B54. " S LRICDIEN=+$$CODEN^ICDEX(LREPICDX,80) D

 .Q:+LRICDIEN'>0

 .S LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDIEN,,)

 .Q:+LRTMP<0

 .D SETIC(LRICDIEN)

 ;DENGUE   PATH12

 S LRPATH=12

 F LREPICDX="A90. ","A91. ","A93.8 " S LRICDIEN=+$$CODEN^ICDEX(LREPICDX,80) D

 .Q:+LRICDIEN'>0

 .S LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDIEN,,)

 .Q:+LRTMP<0

 .D SETIC(LRICDIEN)

 ;

 ;JAKOB-CREUTZFELDT DIS   PATH13

 S LRPATH=13

 F LREPICDX="A81.00 ","A81.01 ","A81.09 ","A81.1 ","A81.2 ","A81.81 ","A81.82 ","A81.83 ","A81.89 ","A81.9 " S LRICDIEN=+$$CODEN^ICDEX(LREPICDX,80) D

 .Q:+LRICDIEN'>0

 .S LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDIEN,,)

 .Q:+LRTMP<0

 .D SETIC(LRICDIEN)

 ;

 ;LEGIONELLA   PATH7

 S LRPATH=7

 F LREPICDX="A48.1 ","A48.2 ","A48.8 " S LRICDIEN=+$$CODEN^ICDEX(LREPICDX,80) D

 .Q:+LRICDIEN'>0

 .S LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDIEN,,)

 .Q:+LRTMP<0

 .D SETIC(LRICDIEN)

 ;

 ;CRYPTOSPORIDIUM   PATH9

 S LRPATH=9

 F LREPICDX="A07.2 ","A07.9 " S LRICDIEN=+$$CODEN^ICDEX(LREPICDX,80) D

 .Q:+LRICDIEN'>0

 .S LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDIEN,,)

 .Q:+LRTMP<0

 .D SETIC(LRICDIEN)

 ;

EXIT K LRPATH,LRINT,X,Y,DA,DIC,DIE,DR,LRICDNO,DD,LRCSYS,LREPICDX,LRICDIEN

 K LRND,LRNDM,LRANT,LRTMP,LRMSG,LRANM

 ;

 Q

SETIC(LRINT) ;ADD THE ENTRY FOR ICD

 Q:$D(^LAB(69.5,LRPATH,3,"B",LRINT))

 S LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRINT,,)

 Q:LRTMP'>0

 S LRMSG="Adding "_$P(LRTMP,U,2)_" "_$P(LRTMP,U,4)_" into "

 S LRMSG=LRMSG_$P(^LAB(69.5,LRPATH,0),U,1)

 D BMES^XPDUTL(LRMSG)

 K DD

 S DIC="^LAB(69.5,"_LRPATH_",3,",DIC(0)="L",X=LRINT

 S DIC("P")=$P(^DD(69.5,4,0),U,2),DA(1)=LRPATH

 D FILE^DICN

 S DIE="^LAB(69.5,"_LRPATH_",3,",DR="1////"_$P(LRTMP,U,20) D ^DIE

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LR421P   2843     printed  Mar 13, 2025@21:08:20                                                                                                                                                                                                      Page 2

LR421P    ;DALISC/SED - LR*5.2*421 PATCH POST INIT ROUTINE ;10 Oct 2013  4:49 PM

 +1       ;;5.2;LAB SERVICE;**421**;Sep 27, 1994;Build 48

EN        ;

 +1        DO BMES^XPDUTL("**** ICD 10 Remediation****")

 +2        DO BMES^XPDUTL("**Updating Emerging Pathogen File (69.5) with ICD Codes**")

CONVERT   ;

 +1        SET LRCSYS="10D"

 +2        IF $TEXT(^LREPICD)]""

               DO ICDCONVT^LREPICD

ICD       ;Add the ICD codes to the file.

 +1       ;SET CURRENT CODES TO APPROPRIATE CODE SYSTEMS

 +2        NEW LRICDDA,LRICDCOD

           KILL LRPATH

           SET LRPATH=0

           FOR 

               SET LRPATH=$ORDER(^LAB(69.5,LRPATH))

               if +LRPATH=0

                   QUIT 

               Begin DoDot:1

 +3                IF $DATA(^LAB(69.5,LRPATH,3))

                       SET LRICDDA=0

                       FOR 

                           SET LRICDDA=$ORDER(^LAB(69.5,LRPATH,3,LRICDDA))

                           if +LRICDDA=0

                               QUIT 

                           Begin DoDot:2

 +4                            KILL LRSET

                               SET LRICDCOD=+(^LAB(69.5,LRPATH,3,LRICDDA,0))

                               SET LRSET=$$CSI^ICDEX(80,LRICDCOD)

 +5                            SET DIE="^LAB(69.5,"_LRPATH_",3,"

                               SET DA=LRICDDA

                               SET DR="1////"_LRSET

                               DO ^DIE

                           End DoDot:2

 +6                QUIT 

               End DoDot:1

 +7       ;LEISHMANIASIS   PATH14

 +8        SET LRPATH=14

 +9        FOR LRICDNO=0,1,2,9

               SET LREPICDX="B55."_LRICDNO_" "

               SET LRICDIEN=+$$CODEN^ICDEX(LREPICDX,80)

               Begin DoDot:1

 +10               if +LRICDIEN'>0

                       QUIT 

 +11               SET LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDIEN,,)

 +12               if +LRTMP<0

                       QUIT 

 +13               DO SETIC(LRICDIEN)

               End DoDot:1

 +14      ;MALARIA   PATH11

 +15       SET LRPATH=11

 +16       FOR LREPICDX="B50.0 ","B50.8 ","B50.9 ","B51.0 ","B51.8 ","B51.9 ","B52.0 ","B52.8 ","B52.9 ","B53.0 ","B53.1 ","B53.8 ","B54. "

               SET LRICDIEN=+$$CODEN^ICDEX(LREPICDX,80)

               Begin DoDot:1

 +17               if +LRICDIEN'>0

                       QUIT 

 +18               SET LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDIEN,,)

 +19               if +LRTMP<0

                       QUIT 

 +20               DO SETIC(LRICDIEN)

               End DoDot:1

 +21      ;DENGUE   PATH12

 +22       SET LRPATH=12

 +23       FOR LREPICDX="A90. ","A91. ","A93.8 "

               SET LRICDIEN=+$$CODEN^ICDEX(LREPICDX,80)

               Begin DoDot:1

 +24               if +LRICDIEN'>0

                       QUIT 

 +25               SET LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDIEN,,)

 +26               if +LRTMP<0

                       QUIT 

 +27               DO SETIC(LRICDIEN)

               End DoDot:1

 +28      ;

 +29      ;JAKOB-CREUTZFELDT DIS   PATH13

 +30       SET LRPATH=13

 +31       FOR LREPICDX="A81.00 ","A81.01 ","A81.09 ","A81.1 ","A81.2 ","A81.81 ","A81.82 ","A81.83 ","A81.89 ","A81.9 "

               SET LRICDIEN=+$$CODEN^ICDEX(LREPICDX,80)

               Begin DoDot:1

 +32               if +LRICDIEN'>0

                       QUIT 

 +33               SET LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDIEN,,)

 +34               if +LRTMP<0

                       QUIT 

 +35               DO SETIC(LRICDIEN)

               End DoDot:1

 +36      ;

 +37      ;LEGIONELLA   PATH7

 +38       SET LRPATH=7

 +39       FOR LREPICDX="A48.1 ","A48.2 ","A48.8 "

               SET LRICDIEN=+$$CODEN^ICDEX(LREPICDX,80)

               Begin DoDot:1

 +40               if +LRICDIEN'>0

                       QUIT 

 +41               SET LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDIEN,,)

 +42               if +LRTMP<0

                       QUIT 

 +43               DO SETIC(LRICDIEN)

               End DoDot:1

 +44      ;

 +45      ;CRYPTOSPORIDIUM   PATH9

 +46       SET LRPATH=9

 +47       FOR LREPICDX="A07.2 ","A07.9 "

               SET LRICDIEN=+$$CODEN^ICDEX(LREPICDX,80)

               Begin DoDot:1

 +48               if +LRICDIEN'>0

                       QUIT 

 +49               SET LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDIEN,,)

 +50               if +LRTMP<0

                       QUIT 

 +51               DO SETIC(LRICDIEN)

               End DoDot:1

 +52      ;

EXIT       KILL LRPATH,LRINT,X,Y,DA,DIC,DIE,DR,LRICDNO,DD,LRCSYS,LREPICDX,LRICDIEN

 +1        KILL LRND,LRNDM,LRANT,LRTMP,LRMSG,LRANM

 +2       ;

 +3        QUIT 

SETIC(LRINT) ;ADD THE ENTRY FOR ICD

 +1        if $DATA(^LAB(69.5,LRPATH,3,"B",LRINT))

               QUIT 

 +2        SET LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRINT,,)

 +3        if LRTMP'>0

               QUIT 

 +4        SET LRMSG="Adding "_$PIECE(LRTMP,U,2)_" "_$PIECE(LRTMP,U,4)_" into "

 +5        SET LRMSG=LRMSG_$PIECE(^LAB(69.5,LRPATH,0),U,1)

 +6        DO BMES^XPDUTL(LRMSG)

 +7        KILL DD

 +8        SET DIC="^LAB(69.5,"_LRPATH_",3,"

           SET DIC(0)="L"

           SET X=LRINT

 +9        SET DIC("P")=$PIECE(^DD(69.5,4,0),U,2)

           SET DA(1)=LRPATH

 +10       DO FILE^DICN

 +11       SET DIE="^LAB(69.5,"_LRPATH_",3,"

           SET DR="1////"_$PIECE(LRTMP,U,20)

           DO ^DIE

 +12       QUIT