BDGP1003 ;IHS/ITSC/LJF - PRE & POST INSTALL, ENVIRON CHECK FOR PATCH 1003
;;5.3;PIMS;**1003**;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 1002
S PATCH="PIMS*5.3*1002"
I '$$PATCH(PATCH) D
. W !,"You must first install "_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)
;
PRE ;EP;
CLEAN ; clean out ADT ITEM file before restoring data
NEW X
S X=0 F S X=$O(^BDGITM(X)) Q:'X K ^BDGITM(X)
K ^BDGITM("B")
S $P(^BDGITM(0),U,3,4)="0^0"
Q
;
POST ;EP; post install code
D STUFF,KILLID,CDEF,PATCHES,FORM,DSFIX,BULL
Q
;
STUFF ; stuff new "Print A Sheet at Admission" parameter to 1
; and reset days to delinquency if greater than 30
D BMES^XPDUTL("Initializing new ADT parameters . . .")
NEW DA,DIE,DR
S DA=0 F S DA=$O(^BDGPAR(DA)) Q:'DA D
. I $$GET1^DIQ(9009020.1,DA,.16)="" D
. . S DIE="^BDGPAR(",DR=".16///1" D ^DIE
. I $$GET1^DIQ(9009020.1,DA,.12)>30 D
. . S DIE="^BDGPAR(",DR=".12///30" D ^DIE
Q
;
KILLID ; remove VA identifier from file 45.7
D BMES^XPDUTL("Removing VA identifier from file 45.7 . . .")
K ^DD(45.7,0,"ID",1) ;Exemption from SAC #2.2.3.2.7 pending
Q
;
CDEF ; mark awaiting transcription entries under Admin grouping
D BMES^XPDUTL("Marking ""AWAITING TRANS"" deficiencies to ADMIN group . . .")
NEW BDGI,DA,DIE,DR
S DIE="^BDGCD(",DR=".03///ADM"
F BDGI="AWAITING TRANS NS","AWAITING TRANS OR" D
. S DA=$O(^BDGCD("B",BDGI,0)) Q:'DA
. D ^DIE
Q
;
FORM ; update line 4 in ADT FORM - IHS format
D BMES^XPDUTL("Updating line 4 in IHS Clinical Record Brief format . . .")
NEW DIE,DA,DR
S DIE="^BDGFRM(1,""LINE"",4,""ITEM""," S DA(2)=1,DA(1)=4
S DA=$O(^BDGFRM(1,"LINE",4,"ITEM","B",15,0))
I DA S DR=".03///Community Code;.04///20" D ^DIE
S DA=$O(^BDGFRM(1,"LINE",4,"ITEM","B",23,0))
I DA S DR=".03///Admtg Ward;.04///15" D ^DIE
S DA=$O(^BDGFRM(1,"LINE",4,"ITEM","B",22,0))
I DA S DR=".03///Admtg Provider;.04///25" D ^DIE
Q
;
DSFIX ; find and fix any old day surgery entries without zero nodes
D BMES^XPDUTL("Fixing any day surgery entries with errors . . .")
NEW IEN S IEN=0
F S IEN=$O(^ADGDS(IEN)) Q:'IEN I '$D(^ADGDS(IEN,0)) D
. S ^ADGDS(IEN,0)=IEN,^ADGDS("B",IEN,IEN)=""
. W !?5,"Entry for patient #",$$HRCN^BDGF2(IEN,DUZ(2))," fixed."
Q
;
BULL ; send bulletins to appropriate users
D BMES^XPDUTL("Sending bulletins to users . . .")
NEW XMB,USER,XMDT,XMY
S XMB="BDG PATCH 1003",XMDT=$$NOW^XLFDT
S USER=0 F S USER=$O(^XUSEC("DGZSYS",USER)) Q:'USER S XMY(USER)=""
D ^XMB
;
S XMB="BSD PATCH 1003",XMDT=$$NOW^XLFDT
K XMY S USER=0 F S USER=$O(^XUSEC("SDZAC",USER)) Q:'USER S XMY(USER)=""
D ^XMB
Q
;
PATCHES ; mark package file entry with old PIMS patch #s required by CSV
D BMES^XPDUTL("Adding VA patch #s to patch history . . .")
NEW PKG,VER,COUNT,PATCH,DA,DIC,X,Y
F NMSP="DG","SD" D
. S PKG=$O(^DIC(9.4,"C",NMSP,0)) Q:'PKG D
. . S VER=$O(^DIC(9.4,PKG,22,"B","5.3",0)) Q:VER<1
. . F COUNT=1:1 S PATCH=$P($T(OLDPATCH+COUNT),";;",2) Q:PATCH="" D
. . . Q:$P($T(OLDPATCH+COUNT),";;",3)'=NMSP ;check namespace
. . . I $D(^DIC(9.4,PKG,22,VER,"PAH","B",PATCH)) Q ;already in file
. . . S DIC="^DIC(9.4,"_PKG_",22,"_VER_",""PAH"","
. . . S DA(2)=PKG,DA(1)=VER,DIC(0)="L"
. . . S DIC("P")=$P(^DD(9.49,1105,0),U,2)
. . . S X=PATCH,DIC("DR")=".02///"_DT_";.03///`"_DUZ
. . . D ^DIC
Q
;
OLDPATCH ;;
;;158 SEQ #0;;DG
;;190 SEQ #0;;DG
;;309 SEQ #0;;DG
;;397 SEQ #364;;DG
;;441 SEQ #386;;DG
;;418 SEQ #416;;DG
;;493 SEQ #430;;DG
;;512 SEQ #447;;DG
;;199 SEQ #220;;SD
;;258 SEQ #245;;SD
;;254 SEQ #247;;SD
;;296 SEQ #259;;SD
BDGP1003 ;IHS/ITSC/LJF - PRE & POST INSTALL, ENVIRON CHECK FOR PATCH 1003
+1 ;;5.3;PIMS;**1003**;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 1002
+5 SET PATCH="PIMS*5.3*1002"
+6 IF '$$PATCH(PATCH)
Begin DoDot:1
+7 WRITE !,"You must first install "_PATCH_"."
SET XPDQUIT=2
End DoDot:1
+8 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 ;
PRE ;EP;
CLEAN ; clean out ADT ITEM file before restoring data
+1 NEW X
+2 SET X=0
FOR
SET X=$ORDER(^BDGITM(X))
IF 'X
QUIT
KILL ^BDGITM(X)
+3 KILL ^BDGITM("B")
+4 SET $PIECE(^BDGITM(0),U,3,4)="0^0"
+5 QUIT
+6 ;
POST ;EP; post install code
+1 DO STUFF
DO KILLID
DO CDEF
DO PATCHES
DO FORM
DO DSFIX
DO BULL
+2 QUIT
+3 ;
STUFF ; stuff new "Print A Sheet at Admission" parameter to 1
+1 ; and reset days to delinquency if greater than 30
+2 DO BMES^XPDUTL("Initializing new ADT parameters . . .")
+3 NEW DA,DIE,DR
+4 SET DA=0
FOR
SET DA=$ORDER(^BDGPAR(DA))
IF 'DA
QUIT
Begin DoDot:1
+5 IF $$GET1^DIQ(9009020.1,DA,.16)=""
Begin DoDot:2
+6 SET DIE="^BDGPAR("
SET DR=".16///1"
DO ^DIE
End DoDot:2
+7 IF $$GET1^DIQ(9009020.1,DA,.12)>30
Begin DoDot:2
+8 SET DIE="^BDGPAR("
SET DR=".12///30"
DO ^DIE
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
KILLID ; remove VA identifier from file 45.7
+1 DO BMES^XPDUTL("Removing VA identifier from file 45.7 . . .")
+2 ;Exemption from SAC #2.2.3.2.7 pending
KILL ^DD(45.7,0,"ID",1)
+3 QUIT
+4 ;
CDEF ; mark awaiting transcription entries under Admin grouping
+1 DO BMES^XPDUTL("Marking ""AWAITING TRANS"" deficiencies to ADMIN group . . .")
+2 NEW BDGI,DA,DIE,DR
+3 SET DIE="^BDGCD("
SET DR=".03///ADM"
+4 FOR BDGI="AWAITING TRANS NS","AWAITING TRANS OR"
Begin DoDot:1
+5 SET DA=$ORDER(^BDGCD("B",BDGI,0))
IF 'DA
QUIT
+6 DO ^DIE
End DoDot:1
+7 QUIT
+8 ;
FORM ; update line 4 in ADT FORM - IHS format
+1 DO BMES^XPDUTL("Updating line 4 in IHS Clinical Record Brief format . . .")
+2 NEW DIE,DA,DR
+3 SET DIE="^BDGFRM(1,""LINE"",4,""ITEM"","
SET DA(2)=1
SET DA(1)=4
+4 SET DA=$ORDER(^BDGFRM(1,"LINE",4,"ITEM","B",15,0))
+5 IF DA
SET DR=".03///Community Code;.04///20"
DO ^DIE
+6 SET DA=$ORDER(^BDGFRM(1,"LINE",4,"ITEM","B",23,0))
+7 IF DA
SET DR=".03///Admtg Ward;.04///15"
DO ^DIE
+8 SET DA=$ORDER(^BDGFRM(1,"LINE",4,"ITEM","B",22,0))
+9 IF DA
SET DR=".03///Admtg Provider;.04///25"
DO ^DIE
+10 QUIT
+11 ;
DSFIX ; find and fix any old day surgery entries without zero nodes
+1 DO BMES^XPDUTL("Fixing any day surgery entries with errors . . .")
+2 NEW IEN
SET IEN=0
+3 FOR
SET IEN=$ORDER(^ADGDS(IEN))
IF 'IEN
QUIT
IF '$DATA(^ADGDS(IEN,0))
Begin DoDot:1
+4 SET ^ADGDS(IEN,0)=IEN
SET ^ADGDS("B",IEN,IEN)=""
+5 WRITE !?5,"Entry for patient #",$$HRCN^BDGF2(IEN,DUZ(2))," fixed."
End DoDot:1
+6 QUIT
+7 ;
BULL ; send bulletins to appropriate users
+1 DO BMES^XPDUTL("Sending bulletins to users . . .")
+2 NEW XMB,USER,XMDT,XMY
+3 SET XMB="BDG PATCH 1003"
SET XMDT=$$NOW^XLFDT
+4 SET USER=0
FOR
SET USER=$ORDER(^XUSEC("DGZSYS",USER))
IF 'USER
QUIT
SET XMY(USER)=""
+5 DO ^XMB
+6 ;
+7 SET XMB="BSD PATCH 1003"
SET XMDT=$$NOW^XLFDT
+8 KILL XMY
SET USER=0
FOR
SET USER=$ORDER(^XUSEC("SDZAC",USER))
IF 'USER
QUIT
SET XMY(USER)=""
+9 DO ^XMB
+10 QUIT
+11 ;
PATCHES ; mark package file entry with old PIMS patch #s required by CSV
+1 DO BMES^XPDUTL("Adding VA patch #s to patch history . . .")
+2 NEW PKG,VER,COUNT,PATCH,DA,DIC,X,Y
+3 FOR NMSP="DG","SD"
Begin DoDot:1
+4 SET PKG=$ORDER(^DIC(9.4,"C",NMSP,0))
IF 'PKG
QUIT
Begin DoDot:2
+5 SET VER=$ORDER(^DIC(9.4,PKG,22,"B","5.3",0))
IF VER<1
QUIT
+6 FOR COUNT=1:1
SET PATCH=$PIECE($TEXT(OLDPATCH+COUNT),";;",2)
IF PATCH=""
QUIT
Begin DoDot:3
+7 ;check namespace
IF $PIECE($TEXT(OLDPATCH+COUNT),";;",3)'=NMSP
QUIT
+8 ;already in file
IF $DATA(^DIC(9.4,PKG,22,VER,"PAH","B",PATCH))
QUIT
+9 SET DIC="^DIC(9.4,"_PKG_",22,"_VER_",""PAH"","
+10 SET DA(2)=PKG
SET DA(1)=VER
SET DIC(0)="L"
+11 SET DIC("P")=$PIECE(^DD(9.49,1105,0),U,2)
+12 SET X=PATCH
SET DIC("DR")=".02///"_DT_";.03///`"_DUZ
+13 DO ^DIC
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
OLDPATCH ;;
+1 ;;158 SEQ #0;;DG
+2 ;;190 SEQ #0;;DG
+3 ;;309 SEQ #0;;DG
+4 ;;397 SEQ #364;;DG
+5 ;;441 SEQ #386;;DG
+6 ;;418 SEQ #416;;DG
+7 ;;493 SEQ #430;;DG
+8 ;;512 SEQ #447;;DG
+9 ;;199 SEQ #220;;SD
+10 ;;258 SEQ #245;;SD
+11 ;;254 SEQ #247;;SD
+12 ;;296 SEQ #259;;SD
