- 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