APSPEC09 ;IHS/CIA/PLS - APSP ENVIRONMENT CHECK ROUTINE ;16-Nov-2010 11:37;SM
;;7.0;IHS PHARMACY MODIFICATIONS;**1009**;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 1009.",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...",!
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
N ID
I '$D(^DD(50,9999999.41,0)) D
.S ^DD(50,9999999.41,0)="OUTPATIENT SITE^50.999999941PA^^9999999.41;0"
.S ^DD(50.999999941,0)="OUTPATIENT SITE SUB-FIELD^^.01^1"
.;S ^DD(50.999999941,0,"NM","OUTPATIENT SITE")=""
;
S ^DD(50,0,"SCR")="I $$SCREEN^APSPMULT(+$G(Y))" ;Apply division screen
S ID=$P(^PSDRUG(0),U,2) I ID'["s" S ID=ID_"s" S $P(^PSDRUG(0),U,2)=ID
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
N I,A,INST,VAL
D CLN50DD
;populate parameter with supported options
F I=1:1 S A=$T(OPTIONS+I) S A=$P(A,";;",2) Q:A="" S INST=$P(A,U),VAL=1 D
.D EN^XPAR("SYS","APSP MULTI DRUG SCREEN OPTION",INST,VAL)
D CLNNVA
D MOVPRF
;D REGPROT("AVA PROVIDER UPDATE MFN_M02","APSP ERX MFN UPDATE",400)
D EN^XPAR("SYS","APSP SS HLO RETENTION DAYS",,7)
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
;
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
; Cleanup Drug File DD
CLN50DD ;EP -
S DIU=50.03,DIU(0)="SD" D EN^DIU2
Q
; Cleanup PCC Link in NVA node
CLNNVA ;EP -
N DFN,IEN,FDA,NVAERR
S DFN=0 F S DFN=$O(^PS(55,"APCC","+1",DFN)) Q:'DFN D
.S IEN=0 F S IEN=$O(^PS(55,"APCC","+1",DFN,IEN)) Q:'IEN D
..S FDA(55.05,IEN_","_DFN_",",9999999.11)="@"
D:$D(FDA) UPDATE^DIE("","FDA",,"NVAERR")
W:$G(DIERR) $G(NVAERR("DIERR",1,"TEXT",1))
Q
; Move Paperles Refill POV nodes from ^XTMP to Parameter
MOVPRF ;EP -
N RXIEN,RFIEN,POV
S RXIEN=0
F S RXIEN=$O(^XTMP("APSPPCC.VPOV",RXIEN)) Q:'RXIEN D
.S RFIEN=0 F S RFIEN=$O(^XTMP("APSPPCC.VPOV",RXIEN,RFIEN)) Q:'RFIEN D
..S POV=$G(^XTMP("APSPPCC.VPOV",RXIEN,RFIEN))
..Q:'$L(POV)
..D ADD^XPAR("SYS","APSP POV CACHE",+RXIEN_","_+RFIEN,$TR(POV,U,"~"))
Q
; Set Mail field in File 55 to DO NOT MAIL if not defined
PPMAIL ;EP -
N DFN
S DFN=0
F S DFN=$O(^PS(55,DFN)) Q:'DFN D
.Q:$L($P($G(^PS(55,DFN,0)),U,3))
.S $P(^PS(55,DFN,0),U,3)=2
Q
OPTIONS ;
;;PSO LM BACKDOOR ORDERS
;;PSJ OE
;;PSO RXEDIT
;;PSJI ORDER
APSPEC09 ;IHS/CIA/PLS - APSP ENVIRONMENT CHECK ROUTINE ;16-Nov-2010 11:37;SM
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1009**;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 1009.",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...",!
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 WRITE !!,"Unable to continue with the installation...",!
End DoDot:1
+11 QUIT
+12 ;
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 NEW ID
+2 IF '$DATA(^DD(50,9999999.41,0))
Begin DoDot:1
+3 SET ^DD(50,9999999.41,0)="OUTPATIENT SITE^50.999999941PA^^9999999.41;0"
+4 SET ^DD(50.999999941,0)="OUTPATIENT SITE SUB-FIELD^^.01^1"
+5 ;S ^DD(50.999999941,0,"NM","OUTPATIENT SITE")=""
End DoDot:1
+6 ;
+7 ;Apply division screen
SET ^DD(50,0,"SCR")="I $$SCREEN^APSPMULT(+$G(Y))"
+8 SET ID=$PIECE(^PSDRUG(0),U,2)
IF ID'["s"
SET ID=ID_"s"
SET $PIECE(^PSDRUG(0),U,2)=ID
+9 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 NEW I,A,INST,VAL
+2 DO CLN50DD
+3 ;populate parameter with supported options
+4 FOR I=1:1
SET A=$TEXT(OPTIONS+I)
SET A=$PIECE(A,";;",2)
IF A=""
QUIT
SET INST=$PIECE(A,U)
SET VAL=1
Begin DoDot:1
+5 DO EN^XPAR("SYS","APSP MULTI DRUG SCREEN OPTION",INST,VAL)
End DoDot:1
+6 DO CLNNVA
+7 DO MOVPRF
+8 ;D REGPROT("AVA PROVIDER UPDATE MFN_M02","APSP ERX MFN UPDATE",400)
+9 DO EN^XPAR("SYS","APSP SS HLO RETENTION DAYS",,7)
+10 QUIT
+11 ; 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 ;
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
+7 ; Cleanup Drug File DD
CLN50DD ;EP -
+1 SET DIU=50.03
SET DIU(0)="SD"
DO EN^DIU2
+2 QUIT
+3 ; Cleanup PCC Link in NVA node
CLNNVA ;EP -
+1 NEW DFN,IEN,FDA,NVAERR
+2 SET DFN=0
FOR
SET DFN=$ORDER(^PS(55,"APCC","+1",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+3 SET IEN=0
FOR
SET IEN=$ORDER(^PS(55,"APCC","+1",DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+4 SET FDA(55.05,IEN_","_DFN_",",9999999.11)="@"
End DoDot:2
End DoDot:1
+5 IF $DATA(FDA)
DO UPDATE^DIE("","FDA",,"NVAERR")
+6 IF $GET(DIERR)
WRITE $GET(NVAERR("DIERR",1,"TEXT",1))
+7 QUIT
+8 ; Move Paperles Refill POV nodes from ^XTMP to Parameter
MOVPRF ;EP -
+1 NEW RXIEN,RFIEN,POV
+2 SET RXIEN=0
+3 FOR
SET RXIEN=$ORDER(^XTMP("APSPPCC.VPOV",RXIEN))
IF 'RXIEN
QUIT
Begin DoDot:1
+4 SET RFIEN=0
FOR
SET RFIEN=$ORDER(^XTMP("APSPPCC.VPOV",RXIEN,RFIEN))
IF 'RFIEN
QUIT
Begin DoDot:2
+5 SET POV=$GET(^XTMP("APSPPCC.VPOV",RXIEN,RFIEN))
+6 IF '$LENGTH(POV)
QUIT
+7 DO ADD^XPAR("SYS","APSP POV CACHE",+RXIEN_","_+RFIEN,$TRANSLATE(POV,U,"~"))
End DoDot:2
End DoDot:1
+8 QUIT
+9 ; Set Mail field in File 55 to DO NOT MAIL if not defined
PPMAIL ;EP -
+1 NEW DFN
+2 SET DFN=0
+3 FOR
SET DFN=$ORDER(^PS(55,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+4 IF $LENGTH($PIECE($GET(^PS(55,DFN,0)),U,3))
QUIT
+5 SET $PIECE(^PS(55,DFN,0),U,3)=2
End DoDot:1
+6 QUIT
OPTIONS ;
+1 ;;PSO LM BACKDOOR ORDERS
+2 ;;PSJ OE
+3 ;;PSO RXEDIT
+4 ;;PSJI ORDER
