- APSPEC14 ;IHS/CIA/PLS - APSP ENVIRONMENT CHECK ROUTINE ;25-May-2012 17:17;PLS
- ;;7.0;IHS PHARMACY MODIFICATIONS;**1014**;Sep 23, 2004;Build 5
- ;
- 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 1014.",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
- Q
- ;
- LMCLNUP ;EP-
- N IEN,IENC,FDA
- S IEN=$$FIND1^DIC(409.61,,"X","APSP COMPLETE ORDERS")
- Q:'IEN
- S IENC=$$FIND1^DIC(409.621,","_IEN_",","X","ORDNUM")
- Q:'IENC
- S FDA(409.621,IENC_","_IEN_",",.01)="@"
- D FILE^DIE("K","FDA")
- 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 DATA,INSDT
- I $$INSTALDT^XPDUTL("APSP*7.0*1013",.DATA) D
- .S INSDT=$P($O(DATA(0)),".")
- .D FIXEXP(INSDT)
- Q
- ;
- FIXEXP(INSDT) ; EP-
- N FDT,RX,DRG,EXTEXP,X2,NEXPDT,ISSDT,RX0
- S FDT=INSDT-.01 F S FDT=$O(^PSRX("AD",FDT)) Q:'FDT D
- .S RX=0 F S RX=$O(^PSRX("AD",FDT,RX)) Q:'RX D
- ..Q:'$$RMNRFL^APSPFUNC(RX) ;quit if no remaining fills
- ..N DA,DR,DIE
- ..S RX0=^PSRX(RX,0)
- ..S DRG=+$P(RX0,U,6)
- ..S ISSDT=$P(RX0,U,13)
- ..Q:'$$ISSCH^APSPFNC2(DRG,"345") ;quit if not a schedule 3-5 drug
- ..S EXTEXP=$$GET1^DIQ(50,DRG,9999999.08)
- ..S X2=$S(EXTEXP:EXTEXP,1:184)
- ..S NEXPDT=$$FMADD^XLFDT(ISSDT,X2)
- ..S DA=RX,DIE="^PSRX("
- ..S DR="26///"_NEXPDT D ^DIE
- ..W !,"Fixed Expiration date for RX IEN: "_RX
- 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
- ; UnRegister a protocol from an extended action protocol
- ; Input: P-Parent protocol
- ; C-Child protocol
- UREGPROT(P,C,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 IENARY(2)=$$FIND1^DIC(101.01,","_IENARY(1)_",","",C)
- .S FDA(101.01,IENARY(2)_","_IENARY(1)_",",.01)="@"
- .D UPDATE^DIE("S","FDA","","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
- APSPEC14 ;IHS/CIA/PLS - APSP ENVIRONMENT CHECK ROUTINE ;25-May-2012 17:17;PLS
- +1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1014**;Sep 23, 2004;Build 5
- +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 1014.",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 QUIT
- +2 ;
- LMCLNUP ;EP-
- +1 NEW IEN,IENC,FDA
- +2 SET IEN=$$FIND1^DIC(409.61,,"X","APSP COMPLETE ORDERS")
- +3 IF 'IEN
- QUIT
- +4 SET IENC=$$FIND1^DIC(409.621,","_IEN_",","X","ORDNUM")
- +5 IF 'IENC
- QUIT
- +6 SET FDA(409.621,IENC_","_IEN_",",.01)="@"
- +7 DO FILE^DIE("K","FDA")
- +8 QUIT
- +9 ;
- 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 DATA,INSDT
- +2 IF $$INSTALDT^XPDUTL("APSP*7.0*1013",.DATA)
- Begin DoDot:1
- +3 SET INSDT=$PIECE($ORDER(DATA(0)),".")
- +4 DO FIXEXP(INSDT)
- End DoDot:1
- +5 QUIT
- +6 ;
- FIXEXP(INSDT) ; EP-
- +1 NEW FDT,RX,DRG,EXTEXP,X2,NEXPDT,ISSDT,RX0
- +2 SET FDT=INSDT-.01
- FOR
- SET FDT=$ORDER(^PSRX("AD",FDT))
- IF 'FDT
- QUIT
- Begin DoDot:1
- +3 SET RX=0
- FOR
- SET RX=$ORDER(^PSRX("AD",FDT,RX))
- IF 'RX
- QUIT
- Begin DoDot:2
- +4 ;quit if no remaining fills
- IF '$$RMNRFL^APSPFUNC(RX)
- QUIT
- +5 NEW DA,DR,DIE
- +6 SET RX0=^PSRX(RX,0)
- +7 SET DRG=+$PIECE(RX0,U,6)
- +8 SET ISSDT=$PIECE(RX0,U,13)
- +9 ;quit if not a schedule 3-5 drug
- IF '$$ISSCH^APSPFNC2(DRG,"345")
- QUIT
- +10 SET EXTEXP=$$GET1^DIQ(50,DRG,9999999.08)
- +11 SET X2=$SELECT(EXTEXP:EXTEXP,1:184)
- +12 SET NEXPDT=$$FMADD^XLFDT(ISSDT,X2)
- +13 SET DA=RX
- SET DIE="^PSRX("
- +14 SET DR="26///"_NEXPDT
- DO ^DIE
- +15 WRITE !,"Fixed Expiration date for RX IEN: "_RX
- End DoDot:2
- End DoDot:1
- +16 QUIT
- +17 ; 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 ; UnRegister a protocol from an extended action protocol
- +13 ; Input: P-Parent protocol
- +14 ; C-Child protocol
- UREGPROT(P,C,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 IENARY(2)=$$FIND1^DIC(101.01,","_IENARY(1)_",","",C)
- +8 SET FDA(101.01,IENARY(2)_","_IENARY(1)_",",.01)="@"
- +9 DO UPDATE^DIE("S","FDA","","ERR")
- End DoDot:1
- +10 QUIT
- 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