APSPEC08.m

APSPEC08 ;IHS/CIA/PLS - APSP ENVIRONMENT CHECK ROUTINE ;14-Oct-2009 14:36;SM

 ;;7.0;IHS PHARMACY MODIFICATIONS;**1008**;Sep 23, 2004

 ;

ENV ;EP

 ;

 S X=$$GET1^DIQ(200,DUZ,.01)

 W !!,$$CJ^XLFSTR("Hello, "_$P(X,",",2)_" "_$P(X,","),IOM)

 W !!,$$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_", Patch 1008.",IOM)

 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0  ; Suppress the Disable options and Move routines prompts

 S XPDABORT=0

 I 'XPDABORT D

 .W !!,"All requirements for installation have been met...",!

 .D POSTPSX

 E  D

 .W !!,"Unable to continue with the installation...",!

 Q

 ;

MES(TXT,QUIT) ;EP

 D BMES^XPDUTL("  "_$G(TXT))

 S:$G(QUIT) XPDABORT=QUIT

 Q

 ;

PRE ;EP - Pre-init

 Q

RENXPAR(OLD,NEW) ; Rename parameter

 N IEN,FDA,FIL

 S FIL=8989.51

 Q:$$FIND1^DIC(FIL,,"X",NEW)  ; New name already exists

 S IEN=$$FIND1^DIC(FIL,,"X",OLD)

 Q:'IEN  ; Old name doesn't exist

 S FDA(FIL,IEN_",",.01)=NEW

 D FILE^DIE("E","FDA")

 Q

 ;

REMXPAR(PAR) ;Remove values stored for a given parameter

 N PIEN,ENT,INT,VIEN,DIK,DA

 S PIEN=$O(^XPAR(8989.51,"B",PAR,0))

 Q:'PIEN

 S ENT=0 F  S ENT=$O(^XPAR(8989.5,"AC",PIEN,ENT)) Q:ENT=""  D  ;Entity

 .S INT=0 F  S INT=$O(^XPAR(8989.5,"AC",PIEN,ENT,INT)) Q:INT=""  D  ;Instance

 ..S DA=0 F  S DA=$O(^XPAR(8989.5,"AC",PIEN,ENT,INT,DA)) Q:'DA  D  ;Value IEN

 ...S DIK="^XTV(8989.5," D ^DIK

 Q

POST ;EP

 ;D EN^XPAR("SYS","APSP AUTO RX ADD PRV COMMENT",,"Y")

 ;D EN^XPAR("SYS","APSP AUTO RX ELECTRONIC",,"N")

 D ZAL2FIX

 D AAPPGRP(50,"GMTS")

 Q

 ; Rebuild ZAL2 xref for partial dispenses

ZAL2FIX ; EP

 D BMES^XPDUTL("Rebuilding ZAL2 crossreference...")

 N RX,DIK,DA

 S RX=0 F  S RX=$O(^PSRX(RX)) Q:'RX  D

 .Q:'$D(^PSRX(RX,"P"))

 .S DA(1)=RX

 .S DIK="^PSRX("_DA(1)_",""P"",",DIK(1)="8^ZAL2"

 .D ENALL^DIK

 Q

 ; Add given namespace to Application

AAPPGRP(FILE,NMSP) ;EP

 N FDA,IEN,ERR

 Q:'$G(FILE)!('$L(NMSP))

 S FDA(1.005,"?+1,"_FILE_",",.01)=NMSP

 D UPDATE^DIE("","FDA","IEN","ERR")

 Q

 ; Register a protocol to an extended action protocol

 ; Input: P-Parent protocol

 ;        C-Child protocol

 ;     SEQ-Sequence Number

REGPROT(P,C,SEQ,ERR) ;EP

 N IENARY,PIEN,AIEN,FDA

 D

 .I '$L(P)!('$L(C)) S ERR="Missing input parameter" Q

 .S IENARY(1)=$$FIND1^DIC(101,"","",P)

 .S AIEN=$$FIND1^DIC(101,"","",C)

 .I 'IENARY(1)!'AIEN S ERR="Unknown protocol name" Q

 .S FDA(101.01,"?+2,"_IENARY(1)_",",.01)=AIEN

 .S FDA(101.01,"?+2,"_IENARY(1)_",",3)=SEQ

 .D UPDATE^DIE("S","FDA","IENARY","ERR")

 ;Q:$Q $G(ERR)=""

 Q

 ; Post-install for CMOP DD 1.0 build

POSTPSX ;EP

 ; Set current version field of PSX package to v2.0

 D SETPKGV("CMOP","2.0")

 Q

 ;

SETPKGV(PKG,VER) ;EP

 N PIEN,FDA

 S PIEN=$$FIND1^DIC(9.4,,,PKG)

 Q:'PIEN

 S FDA(9.4,PIEN_",",13)=VER

 D UPDATE^DIE(,"FDA")

 Q

APSPEC08  ;IHS/CIA/PLS - APSP ENVIRONMENT CHECK ROUTINE ;14-Oct-2009 14:36;SM

 +1       ;;7.0;IHS PHARMACY MODIFICATIONS;**1008**;Sep 23, 2004

 +2       ;

ENV       ;EP

 +1       ;

 +2        SET X=$$GET1^DIQ(200,DUZ,.01)

 +3        WRITE !!,$$CJ^XLFSTR("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","),IOM)

 +4        WRITE !!,$$CJ^XLFSTR("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_$PIECE($TEXT(+2),";",3)_", Patch 1008.",IOM)

 +5       ; Suppress the Disable options and Move routines prompts

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

 +6        SET XPDABORT=0

 +7        IF 'XPDABORT

               Begin DoDot:1

 +8                WRITE !!,"All requirements for installation have been met...",!

 +9                DO POSTPSX

               End DoDot:1

 +10      IF '$TEST

               Begin DoDot:1

 +11               WRITE !!,"Unable to continue with the installation...",!

               End DoDot:1

 +12       QUIT 

 +13      ;

MES(TXT,QUIT) ;EP

 +1        DO BMES^XPDUTL("  "_$GET(TXT))

 +2        IF $GET(QUIT)

               SET XPDABORT=QUIT

 +3        QUIT 

 +4       ;

PRE       ;EP - Pre-init

 +1        QUIT 

RENXPAR(OLD,NEW) ; Rename parameter

 +1        NEW IEN,FDA,FIL

 +2        SET FIL=8989.51

 +3       ; New name already exists

           IF $$FIND1^DIC(FIL,,"X",NEW)

               QUIT 

 +4        SET IEN=$$FIND1^DIC(FIL,,"X",OLD)

 +5       ; Old name doesn't exist

           IF 'IEN

               QUIT 

 +6        SET FDA(FIL,IEN_",",.01)=NEW

 +7        DO FILE^DIE("E","FDA")

 +8        QUIT 

 +9       ;

REMXPAR(PAR) ;Remove values stored for a given parameter

 +1        NEW PIEN,ENT,INT,VIEN,DIK,DA

 +2        SET PIEN=$ORDER(^XPAR(8989.51,"B",PAR,0))

 +3        IF 'PIEN

               QUIT 

 +4       ;Entity

           SET ENT=0

           FOR 

               SET ENT=$ORDER(^XPAR(8989.5,"AC",PIEN,ENT))

               IF ENT=""

                   QUIT 

               Begin DoDot:1

 +5       ;Instance

                   SET INT=0

                   FOR 

                       SET INT=$ORDER(^XPAR(8989.5,"AC",PIEN,ENT,INT))

                       IF INT=""

                           QUIT 

                       Begin DoDot:2

 +6       ;Value IEN

                           SET DA=0

                           FOR 

                               SET DA=$ORDER(^XPAR(8989.5,"AC",PIEN,ENT,INT,DA))

                               IF 'DA

                                   QUIT 

                               Begin DoDot:3

 +7                                SET DIK="^XTV(8989.5,"

                                   DO ^DIK

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +8        QUIT 

POST      ;EP

 +1       ;D EN^XPAR("SYS","APSP AUTO RX ADD PRV COMMENT",,"Y")

 +2       ;D EN^XPAR("SYS","APSP AUTO RX ELECTRONIC",,"N")

 +3        DO ZAL2FIX

 +4        DO AAPPGRP(50,"GMTS")

 +5        QUIT 

 +6       ; Rebuild ZAL2 xref for partial dispenses

ZAL2FIX   ; EP

 +1        DO BMES^XPDUTL("Rebuilding ZAL2 crossreference...")

 +2        NEW RX,DIK,DA

 +3        SET RX=0

           FOR 

               SET RX=$ORDER(^PSRX(RX))

               IF 'RX

                   QUIT 

               Begin DoDot:1

 +4                IF '$DATA(^PSRX(RX,"P"))

                       QUIT 

 +5                SET DA(1)=RX

 +6                SET DIK="^PSRX("_DA(1)_",""P"","

                   SET DIK(1)="8^ZAL2"

 +7                DO ENALL^DIK

               End DoDot:1

 +8        QUIT 

 +9       ; Add given namespace to Application

AAPPGRP(FILE,NMSP) ;EP

 +1        NEW FDA,IEN,ERR

 +2        IF '$GET(FILE)!('$LENGTH(NMSP))

               QUIT 

 +3        SET FDA(1.005,"?+1,"_FILE_",",.01)=NMSP

 +4        DO UPDATE^DIE("","FDA","IEN","ERR")

 +5        QUIT 

 +6       ; Register a protocol to an extended action protocol

 +7       ; Input: P-Parent protocol

 +8       ;        C-Child protocol

 +9       ;     SEQ-Sequence Number

REGPROT(P,C,SEQ,ERR) ;EP

 +1        NEW IENARY,PIEN,AIEN,FDA

 +2        Begin DoDot:1

 +3            IF '$LENGTH(P)!('$LENGTH(C))

                   SET ERR="Missing input parameter"

                   QUIT 

 +4            SET IENARY(1)=$$FIND1^DIC(101,"","",P)

 +5            SET AIEN=$$FIND1^DIC(101,"","",C)

 +6            IF 'IENARY(1)!'AIEN

                   SET ERR="Unknown protocol name"

                   QUIT 

 +7            SET FDA(101.01,"?+2,"_IENARY(1)_",",.01)=AIEN

 +8            SET FDA(101.01,"?+2,"_IENARY(1)_",",3)=SEQ

 +9            DO UPDATE^DIE("S","FDA","IENARY","ERR")

           End DoDot:1

 +10      ;Q:$Q $G(ERR)=""

 +11       QUIT 

 +12      ; Post-install for CMOP DD 1.0 build

POSTPSX   ;EP

 +1       ; Set current version field of PSX package to v2.0

 +2        DO SETPKGV("CMOP","2.0")

 +3        QUIT 

 +4       ;

SETPKGV(PKG,VER) ;EP

 +1        NEW PIEN,FDA

 +2        SET PIEN=$$FIND1^DIC(9.4,,,PKG)

 +3        IF 'PIEN

               QUIT 

 +4        SET FDA(9.4,PIEN_",",13)=VER

 +5        DO UPDATE^DIE(,"FDA")

 +6        QUIT