BDGP1005 ;IHS/OIT/LJF - PRE & POST INSTALL, ENVIRON CHECK FOR PATCH 1005
;;5.3;PIMS;**1005**;MAY 28, 2004
;
CKENV ; environment check code
;Prevents "Disable Options..." and "Move Routines..." questions
S XPDDIQ("XPZ1")=0,XPPDIQ("XPZ2")=0
;
; now check for patch 1004
NEW PATCH S PATCH="PIMS*5.3*1004"
I '$$PATCH(PATCH) D Q
. W !,"You must first install "_PATCH_"." S XPDQUIT=2
;
; check for test version of patch 1004
I $$TEST(PATCH) D Q
. W !,"You have a TEST version of "_PATCH_" installed. Please install the released patch. . ."
. S XPDQUIT=2
;
Q
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 numbers
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)
;
TEST(X) ; return 1 if site is running an iteration version of patch
NEW IEN
S IEN=$O(^XPD(9.6,"B",X,0)) I 'IEN Q 1 ;not test version but bad xref
I $G(^XPD(9.6,IEN,1,1,0))["ITERATION #" Q 1
Q 0
;
PRE ;EP;
Q
;
POST ;EP; post install code
D AGE,PROT1,PROT2,PREFIX,AUTHBED
Q
;
AGE ; fix code in ADT ITEM to use AGE^AUPNPAT instead of delelted line AGE^BDGF2
D BMES^XPDUTL("Updating AGE code in ADT ITEMS file . . .")
NEW IEN,STR,CALL
S IEN=0 F S IEN=$O(^BDGITM(IEN)) Q:'IEN D
. Q:$G(^BDGITM(IEN,1))'["AGE^BDGF2"
. S STR=^BDGITM(IEN,1),CALL("AGE^BDGF2")="AGE^AUPNPAT",STR=$$REPLACE^XLFSTR(STR,.CALL)
. S ^BDGITM(IEN,1)=STR
Q
;
PROT1 ; switch Rx Profiles with Other Reports under BSDAM MENU protocol menu
NEW PROT,OLD,NEW,IEN,DIE,DA,DR
S PROT=$O(^ORD(101,"B","BSDAM MENU",0)) Q:'PROT
S OLD=$O(^ORD(101,"B","BSDAM RX PROFILES",0)) Q:'OLD
S NEW=$O(^ORD(101,"B","BSDAM OTHER REPORTS",0)) Q:'NEW
S IEN=$O(^ORD(101,PROT,10,"B",OLD,0)) Q:'IEN
D BMES^XPDUTL("Switching Rx Profiles for Other Reports under AM . . .")
;
S DIE="^ORD(101,"_PROT_",10,",DA(1)=PROT,DA=IEN
S DR=".01///`"_NEW_";2///OR"
D ^DIE
Q
;
PROT2 ; fix entry action for BSDAM ADD ENCOUNTER (only run at check-in)
NEW X
S X=$O(^ORD(101,"B","BSDAM ADD ENCOUNTER",0)) Q:'X
D BMES^XPDUTL("Fixing Scheduling Event Driver - add to file 409.68 only at check-in . . .")
S ^ORD(101,X,20)="I $G(SDAMEVT)=4 D APPT^SDVSIT(DFN,SDT,SDCL,$G(BSDVSTN))"
Q
;
PREFIX ; remove all additional prefixes to PIMS Package file entry
NEW PKG,IEN,PFX,DD,DO,DIC,DA,FIRST
S PKG=$O(^DIC(9.4,"C","PIMS",0)) Q:'PKG
S DIK="^DIC(9.4,"_PKG_",14,"
S FIRST=1
F PFX="BDG","BSD","DG","SD","SC","VADPT" D
. Q:'$D(^DIC(9.4,PKG,14,"B",PFX)) ;skip if not there
. I FIRST D BMES^XPDUTL("Adding all Prefixes to PIMS package file entry. . . ") S FIRST=0
. S DA(1)=PKG,DA=$O(^DIC(9.4,PKG,14,"B",PFX,0)) I DA D ^DIK
Q
;
AUTHBED ; copy authorized bed info to new data structure
NEW CENI,WARD,DONE,FIELD,BEDS,DIC,DLAYGO,DA,DIE,DR,X,Y
; first see if this has already been run
S DONE=0,WARD=0 F S WARD=$O(^BDGWD(WARD)) Q:'WARD Q:DONE D
. I $O(^BDGWD(WARD,2,0)) S DONE=1
Q:DONE
;
D BMES^XPDUTL("Copying authorized bed counts into a multiple . . .")
; if not, copy into multiple using census init date
S CENI=$$GET1^DIQ(43,1,10,"I") ;census intialization date
S WARD=0 F S WARD=$O(^BDGWD(WARD)) Q:'WARD D
. F FIELD=102,103,111,112,113,114,115,116,117,118,119 D
. . S BEDS=$$GET1^DIQ(9009016.5,WARD,FIELD) Q:BEDS<1
. . S DIC="^BDGWD("_WARD_",2,",DIC(0)="L",DLAYGO=9009015.52
. . S DA(1)=WARD,X=CENI K DD,DO D FILE^DICN Q:'Y
. . S DIE=DIC,DA=+Y,DR=".03///"_BEDS_";.02///"_$P($T(@FIELD),";;",2)
. . D ^DIE
Q
;
FIELD ;;
102 ;;IC;;
103 ;;PC;;
111 ;;AM;;
112 ;;AS;;
113 ;;PM;;
114 ;;PS;;
115 ;;OB;;
116 ;;NB;;
117 ;;TB;;
118 ;;AL;;
119 ;;MH;;
BDGP1005 ;IHS/OIT/LJF - PRE & POST INSTALL, ENVIRON CHECK FOR PATCH 1005
+1 ;;5.3;PIMS;**1005**;MAY 28, 2004
+2 ;
CKENV ; environment check code
+1 ;Prevents "Disable Options..." and "Move Routines..." questions
+2 SET XPDDIQ("XPZ1")=0
SET XPPDIQ("XPZ2")=0
+3 ;
+4 ; now check for patch 1004
+5 NEW PATCH
SET PATCH="PIMS*5.3*1004"
+6 IF '$$PATCH(PATCH)
Begin DoDot:1
+7 WRITE !,"You must first install "_PATCH_"."
SET XPDQUIT=2
End DoDot:1
QUIT
+8 ;
+9 ; check for test version of patch 1004
+10 IF $$TEST(PATCH)
Begin DoDot:1
+11 WRITE !,"You have a TEST version of "_PATCH_" installed. Please install the released patch. . ."
+12 SET XPDQUIT=2
End DoDot:1
QUIT
+13 ;
+14 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 numbers
+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 ;
TEST(X) ; return 1 if site is running an iteration version of patch
+1 NEW IEN
+2 ;not test version but bad xref
SET IEN=$ORDER(^XPD(9.6,"B",X,0))
IF 'IEN
QUIT 1
+3 IF $GET(^XPD(9.6,IEN,1,1,0))["ITERATION #"
QUIT 1
+4 QUIT 0
+5 ;
PRE ;EP;
+1 QUIT
+2 ;
POST ;EP; post install code
+1 DO AGE
DO PROT1
DO PROT2
DO PREFIX
DO AUTHBED
+2 QUIT
+3 ;
AGE ; fix code in ADT ITEM to use AGE^AUPNPAT instead of delelted line AGE^BDGF2
+1 DO BMES^XPDUTL("Updating AGE code in ADT ITEMS file . . .")
+2 NEW IEN,STR,CALL
+3 SET IEN=0
FOR
SET IEN=$ORDER(^BDGITM(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+4 IF $GET(^BDGITM(IEN,1))'["AGE^BDGF2"
QUIT
+5 SET STR=^BDGITM(IEN,1)
SET CALL("AGE^BDGF2")="AGE^AUPNPAT"
SET STR=$$REPLACE^XLFSTR(STR,.CALL)
+6 SET ^BDGITM(IEN,1)=STR
End DoDot:1
+7 QUIT
+8 ;
PROT1 ; switch Rx Profiles with Other Reports under BSDAM MENU protocol menu
+1 NEW PROT,OLD,NEW,IEN,DIE,DA,DR
+2 SET PROT=$ORDER(^ORD(101,"B","BSDAM MENU",0))
IF 'PROT
QUIT
+3 SET OLD=$ORDER(^ORD(101,"B","BSDAM RX PROFILES",0))
IF 'OLD
QUIT
+4 SET NEW=$ORDER(^ORD(101,"B","BSDAM OTHER REPORTS",0))
IF 'NEW
QUIT
+5 SET IEN=$ORDER(^ORD(101,PROT,10,"B",OLD,0))
IF 'IEN
QUIT
+6 DO BMES^XPDUTL("Switching Rx Profiles for Other Reports under AM . . .")
+7 ;
+8 SET DIE="^ORD(101,"_PROT_",10,"
SET DA(1)=PROT
SET DA=IEN
+9 SET DR=".01///`"_NEW_";2///OR"
+10 DO ^DIE
+11 QUIT
+12 ;
PROT2 ; fix entry action for BSDAM ADD ENCOUNTER (only run at check-in)
+1 NEW X
+2 SET X=$ORDER(^ORD(101,"B","BSDAM ADD ENCOUNTER",0))
IF 'X
QUIT
+3 DO BMES^XPDUTL("Fixing Scheduling Event Driver - add to file 409.68 only at check-in . . .")
+4 SET ^ORD(101,X,20)="I $G(SDAMEVT)=4 D APPT^SDVSIT(DFN,SDT,SDCL,$G(BSDVSTN))"
+5 QUIT
+6 ;
PREFIX ; remove all additional prefixes to PIMS Package file entry
+1 NEW PKG,IEN,PFX,DD,DO,DIC,DA,FIRST
+2 SET PKG=$ORDER(^DIC(9.4,"C","PIMS",0))
IF 'PKG
QUIT
+3 SET DIK="^DIC(9.4,"_PKG_",14,"
+4 SET FIRST=1
+5 FOR PFX="BDG","BSD","DG","SD","SC","VADPT"
Begin DoDot:1
+6 ;skip if not there
IF '$DATA(^DIC(9.4,PKG,14,"B",PFX))
QUIT
+7 IF FIRST
DO BMES^XPDUTL("Adding all Prefixes to PIMS package file entry. . . ")
SET FIRST=0
+8 SET DA(1)=PKG
SET DA=$ORDER(^DIC(9.4,PKG,14,"B",PFX,0))
IF DA
DO ^DIK
End DoDot:1
+9 QUIT
+10 ;
AUTHBED ; copy authorized bed info to new data structure
+1 NEW CENI,WARD,DONE,FIELD,BEDS,DIC,DLAYGO,DA,DIE,DR,X,Y
+2 ; first see if this has already been run
+3 SET DONE=0
SET WARD=0
FOR
SET WARD=$ORDER(^BDGWD(WARD))
IF 'WARD
QUIT
IF DONE
QUIT
Begin DoDot:1
+4 IF $ORDER(^BDGWD(WARD,2,0))
SET DONE=1
End DoDot:1
+5 IF DONE
QUIT
+6 ;
+7 DO BMES^XPDUTL("Copying authorized bed counts into a multiple . . .")
+8 ; if not, copy into multiple using census init date
+9 ;census intialization date
SET CENI=$$GET1^DIQ(43,1,10,"I")
+10 SET WARD=0
FOR
SET WARD=$ORDER(^BDGWD(WARD))
IF 'WARD
QUIT
Begin DoDot:1
+11 FOR FIELD=102,103,111,112,113,114,115,116,117,118,119
Begin DoDot:2
+12 SET BEDS=$$GET1^DIQ(9009016.5,WARD,FIELD)
IF BEDS<1
QUIT
+13 SET DIC="^BDGWD("_WARD_",2,"
SET DIC(0)="L"
SET DLAYGO=9009015.52
+14 SET DA(1)=WARD
SET X=CENI
KILL DD,DO
DO FILE^DICN
IF 'Y
QUIT
+15 SET DIE=DIC
SET DA=+Y
SET DR=".03///"_BEDS_";.02///"_$PIECE($TEXT(@FIELD),";;",2)
+16 DO ^DIE
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
FIELD ;;
102 ;;IC;;
103 ;;PC;;
111 ;;AM;;
112 ;;AS;;
113 ;;PM;;
114 ;;PS;;
115 ;;OB;;
116 ;;NB;;
117 ;;TB;;
118 ;;AL;;
119 ;;MH;;
