Routine: BPXRM203

BPXRM203 ; IHS/MSC/MGH - Version 2.0 Patch 3. ;20-Nov-2014 15:19;du

 ;;2.0;CLINICAL REMINDERS;**1003**;Feb 04, 2005;Build 21

ENV ;EP environment check

 N IN,INSTDA,STAT

 ;Check for the installation of Reminders 2.0

 S IN="CLINICAL REMINDERS 2.0",INSTDA=""

 I '$D(^XPD(9.7,"B",IN)) D  Q

 .W !,"You must first install CLINICAL REMINDERS 2.0 before this patch" S XPDQUIT=2

 S INSTDA=$O(^XPD(9.7,"B",IN,INSTDA),-1)

 S STAT=+$P($G(^XPD(9.7,INSTDA,0)),U,9)

 I STAT'=3 D  Q

 .W !,"CLINICAL REMINDERS 2.0 must be completely installed before installing this patch." S XPDQUIT=2

 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 ;Check for the installation of other patches

 S PATCH="PXRM*2.0*1002"

 I '$$PATCH(PATCH) D  Q

 . W !,"You must first install "_PATCH_"." S XPDQUIT=2

 S IN="IHS STANDARD TERMINOLOGY 1.0",INSTDA=""

 I '$D(^XPD(9.7,"B",IN)) D  Q

 .W !,"You must first install IHS STANDARD TERMINOLOGY 1.0 before this patch" S XPDQUIT=2

 S INSTDA=$O(^XPD(9.7,"B",IN,INSTDA),-1)

 S STAT=+$P($G(^XPD(9.7,INSTDA,0)),U,9)

 I STAT'=3 D  Q

 .W !,"IHS STANDARD TERMINOLOGY 1.0  must be completely installed before installing this patch." S XPDQUIT=2

 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 S IN="IHS CLINICAL REPORTING 14.0",INSTDA=""

 I '$D(^XPD(9.7,"B",IN)) D  Q

 .W !,"You must first install IHS CLINICAL REPORTING 14.0 before this patch" S XPDQUIT=2

 S INSTDA=$O(^XPD(9.7,"B",IN,INSTDA),-1)

 S STAT=+$P($G(^XPD(9.7,INSTDA,0)),U,9)

 I STAT'=3 D  Q

 .W !,"IHS CLINICAL REPORTING 14.0  must be completely installed before installing this patch." S XPDQUIT=2

 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

PATCH(X) ;return 1 if patch X was installed, X=aaaa*nn.nn*nnnn

 ;copy of code from XPDUTL but modified to handle 4 digit IHS patch numb

 Q:X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.4N 0

 NEW NUM,I,J

 S I=$O(^DIC(9.4,"C",$P(X,"*"),0)) Q:'I 0

 S J=$O(^DIC(9.4,I,22,"B",$P(X,"*",2),0)),X=$P(X,"*",3) Q:'J 0

 ;check if patch is just a number

 Q:$O(^DIC(9.4,I,22,J,"PAH","B",X,0)) 1

 S NUM=$O(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))

 Q (X=+NUM)

 ;===============================================================

PRE ;EP pre-init

 ;===============================================================

POST ;Post-install

 D CNAK

 D RTAXEXP

 ;================================================================

CNAK ;Make sure all "NAK" characters are converted back to "^" in

 ;the Exchange File.

 N IEN,TEXT

 D BMES^XPDUTL("Clean up Exchange File entries")

 S IEN=0

 F  S IEN=+$O(^PXD(811.8,IEN)) Q:IEN=0  D

 . D POSTKIDS^PXRMEXU5(IEN)

 ;===============================================================

DELEI ;If the Exchange File entry already exists delete it.

 N ARRAY,IC,IND,LIST,LUVALUE,NUM

 S IC=0

 F  S IC=$O(ARRAY(IC)) Q:'IC  D

 .S LUVALUE(1)=ARRAY(IC,1)

 .D FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")

 .I '$D(LIST) Q

 .S NUM=$P(LIST("DILIST",0),U,1)

 .I NUM'=0 D

 ..F IND=1:1:NUM D

 ... N DA,DIK

 ... S DIK="^PXD(811.8,"

 ... S DA=LIST("DILIST",2,IND)

 ... D ^DIK

RTAXEXP ;Rebuild taxonomy expansions.

 N IEN,IND,TEXT,TNAME

 S TNAME(1)="IHS-BARIUM ENEMA"

 S TNAME(2)="IHS-COLONOSCOPY 2007"

 S TNAME(3)="IHS-DEPO PROVERA ADMIN-2013"

 S TNAME(4)="IHS DEPOPROVERA CODES"

 S TNAME(5)="IHS-FECAL OCCULT LAB TEST"

 S TNAME(6)="IHS-FUNDOSCOPIC EYE CODES 2007"

 S TNAME(7)="IHS-HIGH RISK HPV TEST"

 S TNAME(8)="IHS-HYSTERECTOMY 2009"

 S TNAME(9)="IHS-MAMMOGRAM 2009"

 S TNAME(10)="IHS-PAP CODES 2008"

 S TNAME(11)="IHS-SIGMOIDOSCOPY"

 S TNAME(12)="IHS-BILATERAL MASTECTOMY 2008"

 D BMES^XPDUTL("Rebuilding taxonomy expansions.")

 F IND=1:1:12 D

 . S IEN=$O(^PXD(811.2,"B",TNAME(IND),""))

 . I IEN="" Q

 . S TEXT=" Working on taxonomy "_IEN

 . D BMES^XPDUTL(TEXT)

 . D DELEXTL^PXRMBXTL(IEN)

 . D EXPAND^PXRMBXTL(IEN,"")

BPXRM203  ; IHS/MSC/MGH - Version 2.0 Patch 3. ;20-Nov-2014 15:19;du

 +1       ;;2.0;CLINICAL REMINDERS;**1003**;Feb 04, 2005;Build 21

 +2       ;

ENV       ;EP environment check

 +1        NEW IN,INSTDA,STAT

 +2       ;Check for the installation of Reminders 2.0

 +3        SET IN="CLINICAL REMINDERS 2.0"

           SET INSTDA=""

 +4        IF '$DATA(^XPD(9.7,"B",IN))

               Begin DoDot:1

 +5                WRITE !,"You must first install CLINICAL REMINDERS 2.0 before this patch"

                   SET XPDQUIT=2

               End DoDot:1

               QUIT

 +6        SET INSTDA=$ORDER(^XPD(9.7,"B",IN,INSTDA),-1)

 +7        SET STAT=+$PIECE($GET(^XPD(9.7,INSTDA,0)),U,9)

 +8        IF STAT'=3

               Begin DoDot:1

 +9                WRITE !,"CLINICAL REMINDERS 2.0 must be completely installed before installing this patch."

                   SET XPDQUIT=2

               End DoDot:1

               QUIT

 +10       SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 +11      ;Check for the installation of other patches

 +12       SET PATCH="PXRM*2.0*1002"

 +13       IF '$$PATCH(PATCH)

               Begin DoDot:1

 +14               WRITE !,"You must first install "_PATCH_"."

                   SET XPDQUIT=2

               End DoDot:1

               QUIT

 +15       SET IN="IHS STANDARD TERMINOLOGY 1.0"

           SET INSTDA=""

 +16       IF '$DATA(^XPD(9.7,"B",IN))

               Begin DoDot:1

 +17               WRITE !,"You must first install IHS STANDARD TERMINOLOGY 1.0 before this patch"

                   SET XPDQUIT=2

               End DoDot:1

               QUIT

 +18       SET INSTDA=$ORDER(^XPD(9.7,"B",IN,INSTDA),-1)

 +19       SET STAT=+$PIECE($GET(^XPD(9.7,INSTDA,0)),U,9)

 +20       IF STAT'=3

               Begin DoDot:1

 +21               WRITE !,"IHS STANDARD TERMINOLOGY 1.0  must be completely installed before installing this patch."

                   SET XPDQUIT=2

               End DoDot:1

               QUIT

 +22       SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 +23       SET IN="IHS CLINICAL REPORTING 14.0"

           SET INSTDA=""

 +24       IF '$DATA(^XPD(9.7,"B",IN))

               Begin DoDot:1

 +25               WRITE !,"You must first install IHS CLINICAL REPORTING 14.0 before this patch"

                   SET XPDQUIT=2

               End DoDot:1

               QUIT

 +26       SET INSTDA=$ORDER(^XPD(9.7,"B",IN,INSTDA),-1)

 +27       SET STAT=+$PIECE($GET(^XPD(9.7,INSTDA,0)),U,9)

 +28       IF STAT'=3

               Begin DoDot:1

 +29               WRITE !,"IHS CLINICAL REPORTING 14.0  must be completely installed before installing this patch."

                   SET XPDQUIT=2

               End DoDot:1

               QUIT

 +30       SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 +31       QUIT

PATCH(X)  ;return 1 if patch X was installed, X=aaaa*nn.nn*nnnn

 +1       ;copy of code from XPDUTL but modified to handle 4 digit IHS patch numb

 +2        IF X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.4N

               QUIT 0

 +3        NEW NUM,I,J

 +4        SET I=$ORDER(^DIC(9.4,"C",$PIECE(X,"*"),0))

           IF 'I

               QUIT 0

 +5        SET J=$ORDER(^DIC(9.4,I,22,"B",$PIECE(X,"*",2),0))

           SET X=$PIECE(X,"*",3)

           IF 'J

               QUIT 0

 +6       ;check if patch is just a number

 +7        IF $ORDER(^DIC(9.4,I,22,J,"PAH","B",X,0))

               QUIT 1

 +8        SET NUM=$ORDER(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))

 +9        QUIT (X=+NUM)

 +10      ;===============================================================

PRE       ;EP pre-init

 +1        QUIT

 +2       ;===============================================================

POST      ;Post-install

 +1        DO CNAK

 +2        DO RTAXEXP

 +3        QUIT

 +4       ;================================================================

CNAK      ;Make sure all "NAK" characters are converted back to "^" in

 +1       ;the Exchange File.

 +2        NEW IEN,TEXT

 +3        DO BMES^XPDUTL("Clean up Exchange File entries")

 +4        SET IEN=0

 +5        FOR

               SET IEN=+$ORDER(^PXD(811.8,IEN))

               IF IEN=0

                   QUIT

               Begin DoDot:1

 +6                DO POSTKIDS^PXRMEXU5(IEN)

               End DoDot:1

 +7        QUIT

 +8       ;

 +9       ;===============================================================

DELEI     ;If the Exchange File entry already exists delete it.

 +1        NEW ARRAY,IC,IND,LIST,LUVALUE,NUM

 +2        SET IC=0

 +3        FOR

               SET IC=$ORDER(ARRAY(IC))

               IF 'IC

                   QUIT

               Begin DoDot:1

 +4                SET LUVALUE(1)=ARRAY(IC,1)

 +5                DO FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")

 +6                IF '$DATA(LIST)

                       QUIT

 +7                SET NUM=$PIECE(LIST("DILIST",0),U,1)

 +8                IF NUM'=0

                       Begin DoDot:2

 +9                        FOR IND=1:1:NUM

                               Begin DoDot:3

 +10                               NEW DA,DIK

 +11                               SET DIK="^PXD(811.8,"

 +12                               SET DA=LIST("DILIST",2,IND)

 +13                               DO ^DIK

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +14       QUIT

 +15      ;

RTAXEXP   ;Rebuild taxonomy expansions.

 +1        NEW IEN,IND,TEXT,TNAME

 +2        SET TNAME(1)="IHS-BARIUM ENEMA"

 +3        SET TNAME(2)="IHS-COLONOSCOPY 2007"

 +4        SET TNAME(3)="IHS-DEPO PROVERA ADMIN-2013"

 +5        SET TNAME(4)="IHS DEPOPROVERA CODES"

 +6        SET TNAME(5)="IHS-FECAL OCCULT LAB TEST"

 +7        SET TNAME(6)="IHS-FUNDOSCOPIC EYE CODES 2007"

 +8        SET TNAME(7)="IHS-HIGH RISK HPV TEST"

 +9        SET TNAME(8)="IHS-HYSTERECTOMY 2009"

 +10       SET TNAME(9)="IHS-MAMMOGRAM 2009"

 +11       SET TNAME(10)="IHS-PAP CODES 2008"

 +12       SET TNAME(11)="IHS-SIGMOIDOSCOPY"

 +13       SET TNAME(12)="IHS-BILATERAL MASTECTOMY 2008"

 +14       DO BMES^XPDUTL("Rebuilding taxonomy expansions.")

 +15       FOR IND=1:1:12

               Begin DoDot:1

 +16               SET IEN=$ORDER(^PXD(811.2,"B",TNAME(IND),""))

 +17               IF IEN=""

                       QUIT

 +18               SET TEXT=" Working on taxonomy "_IEN

 +19               DO BMES^XPDUTL(TEXT)

 +20               DO DELEXTL^PXRMBXTL(IEN)

 +21               DO EXPAND^PXRMBXTL(IEN,"")

               End DoDot:1

 +22       QUIT

BPXRM203.m