IBDY2117.m

IBDY2117 ;ALB/JLS - KIDS post-install for patch IBD*2.1*17

 ;;Version 2.1 ; AUTOMATED INFO COLLECTION SYS ;**17**; 3-APR-96

 ;

 D PXACT,ICD9

 Q

 ;

PXACT ; -- if PCE is installed, activate Selection Interfaces in file 357.6.

 N I,J,X,Y

 I $D(^AUTTEDT(0)) D  ; education topics installed

 .F I=1:1 S X=$P($T(INTRFCE+I),";;",2) Q:X=""  D

 ..S IBDIEN=$O(^IBE(357.6,"B",X,0))

 ..Q:'IBDIEN

 ..Q:$G(^IBE(357.6,IBDIEN,0))=""

 ..Q:$P($G(^IBE(357.6,IBDIEN,0)),"^",9)=1  ; already available

 ..S $P(^IBE(357.6,IBDIEN,0),"^",9)=1 ; makes it available

 ..D MES^XPDUTL(">>> Updating Package Interface Entry for "_X)

 ..Q

 .Q

 K IBDIEN

 Q

 ;

INTRFCE ;

 ;;PX SELECT EDUCATION TOPICS

 ;;PX SELECT EXAMS

 ;;PX SELECT HEALTH FACTORS

 ;;PX SELECT IMMUNIZATIONS

 ;;PX SELECT SKIN TESTS

 ;;PX SELECT TREATMENTS

 ;;

 ;

ICD9 N IBDA,IBDX

 S IBDA=0 F  S IBDA=$O(^IBE(357.6,"B","INPUT DIAGNOSIS CODE (ICD9)",IBDA)) Q:'IBDA  D

 .S IBDX=$G(^IBE(357.6,IBDA,0))

 .Q:IBDX=""!($P(IBDX,"^")'="INPUT DIAGNOSIS CODE (ICD9)")

 .Q:$P($G(^IBE(357.6,IBDA,12)),"^")="DIAGNOSIS/PROBLEM"

 .S ^IBE(357.6,IBDA,12)="DIAGNOSIS/PROBLEM^1^13^14^2^^^"

 .D MES^XPDUTL(">>> Updating Package Interface Entry for INPUT DIAGNOSIS CODE (ICD9)")

 .Q

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBDY2117   1235     printed  Apr 09, 2024@21:21:09                                                                                                                                                                                                    Page 2

IBDY2117  ;ALB/JLS - KIDS post-install for patch IBD*2.1*17

 +1       ;;Version 2.1 ; AUTOMATED INFO COLLECTION SYS ;**17**; 3-APR-96

 +2       ;

 +3        DO PXACT

           DO ICD9

 +4        QUIT 

 +5       ;

PXACT     ; -- if PCE is installed, activate Selection Interfaces in file 357.6.

 +1        NEW I,J,X,Y

 +2       ; education topics installed

           IF $DATA(^AUTTEDT(0))

               Begin DoDot:1

 +3                FOR I=1:1

                       SET X=$PIECE($TEXT(INTRFCE+I),";;",2)

                       if X=""

                           QUIT 

                       Begin DoDot:2

 +4                        SET IBDIEN=$ORDER(^IBE(357.6,"B",X,0))

 +5                        if 'IBDIEN

                               QUIT 

 +6                        if $GET(^IBE(357.6,IBDIEN,0))=""

                               QUIT 

 +7       ; already available

                           if $PIECE($GET(^IBE(357.6,IBDIEN,0)),"^",9)=1

                               QUIT 

 +8       ; makes it available

                           SET $PIECE(^IBE(357.6,IBDIEN,0),"^",9)=1

 +9                        DO MES^XPDUTL(">>> Updating Package Interface Entry for "_X)

 +10                       QUIT 

                       End DoDot:2

 +11               QUIT 

               End DoDot:1

 +12       KILL IBDIEN

 +13       QUIT 

 +14      ;

INTRFCE   ;

 +1       ;;PX SELECT EDUCATION TOPICS

 +2       ;;PX SELECT EXAMS

 +3       ;;PX SELECT HEALTH FACTORS

 +4       ;;PX SELECT IMMUNIZATIONS

 +5       ;;PX SELECT SKIN TESTS

 +6       ;;PX SELECT TREATMENTS

 +7       ;;

 +8       ;

ICD9       NEW IBDA,IBDX

 +1        SET IBDA=0

           FOR 

               SET IBDA=$ORDER(^IBE(357.6,"B","INPUT DIAGNOSIS CODE (ICD9)",IBDA))

               if 'IBDA

                   QUIT 

               Begin DoDot:1

 +2                SET IBDX=$GET(^IBE(357.6,IBDA,0))

 +3                if IBDX=""!($PIECE(IBDX,"^")'="INPUT DIAGNOSIS CODE (ICD9)")

                       QUIT 

 +4                if $PIECE($GET(^IBE(357.6,IBDA,12)),"^")="DIAGNOSIS/PROBLEM"

                       QUIT 

 +5                SET ^IBE(357.6,IBDA,12)="DIAGNOSIS/PROBLEM^1^13^14^2^^^"

 +6                DO MES^XPDUTL(">>> Updating Package Interface Entry for INPUT DIAGNOSIS CODE (ICD9)")

 +7                QUIT 

               End DoDot:1

 +8        QUIT