PSO7P421 ;ALB/EWL - Patch 421 Post Install routine ;02/04/2013
;;7.0;OUTPATIENT PHARMACY;**421**;DEC 1997;Build 15
;
; ICR Type Description
; ----- ---------- ---------------
; 10013 Supported - ^DIK
; 10141 Supported - XPDUTL
Q
;
POST ;post-install functions are coded here.
; 10141 Supported - XPDUTL
D BMES^XPDUTL(" Starting post-install of PSO*7*421")
D DELAA ; delete ALLOW ALL REJECTS & any 79/88 reject codes from file 52.86
D BMES^XPDUTL(" Finished post-install of PSO*7*421")
Q
;
DELAA ; This updates the 52.86 file - EPHARMACY SITE PARAMETERS
; It will delete ALLOW ALL REJECTS & any 79/88 reject codes
;
; Delete the ALLOW ALL REJECTS data first
; Loop through all entries and delete data from node 0 piece 2
N IEN,RCIEN,DA,DIK S IEN=0
F S IEN=$O(^PS(52.86,IEN)) Q:'IEN D
. ;
. ; Delete any data in node 0 piece 2 as it is no longer used
. S $P(^PS(52.86,IEN,0),U,2)=""
. ;
. ; delete any Transfer Reject codes with a value of 79
. I $D(^PS(52.86,IEN,1,"B",79)) D
. . S RCIEN=0
. . F S RCIEN=$O(^PS(52.86,IEN,1,"B",79,RCIEN)) Q:'RCIEN D
. . . K DA,DIK S DA=RCIEN,DA(1)=IEN,DIK="^PS(52.86,"_IEN_",1," D ^DIK
. ;
. ; delete any Transfer Reject codes with a value of 88
. I $D(^PS(52.86,IEN,1,"B",88)) D
. . S RCIEN=0
. . F S RCIEN=$O(^PS(52.86,IEN,1,"B",88,RCIEN)) Q:'RCIEN D
. . . K DA,DIK S DA=RCIEN,DA(1)=IEN,DIK="^PS(52.86,"_IEN_",1," D ^DIK
;
; Once the ALLOW ALL REJECTS data is deleted,
; Delete the ALLOW ALL REJECTS field from the dictionary
; 10013 Supported - ^DIK
S DIK="^DD(52.86,",DA=1,DA(1)=52.86 D ^DIK
; 10141 Supported - XPDUTL
; Send a message confirming the field deletion
D MES^XPDUTL("ALLOW ALL REJECT field (#1) has been deleted from")
D MES^XPDUTL("the EPHARMACY SITE PARAMETERS file (52.86)")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO7P421 1870 printed Dec 13, 2024@02:23:51 Page 2
PSO7P421 ;ALB/EWL - Patch 421 Post Install routine ;02/04/2013
+1 ;;7.0;OUTPATIENT PHARMACY;**421**;DEC 1997;Build 15
+2 ;
+3 ; ICR Type Description
+4 ; ----- ---------- ---------------
+5 ; 10013 Supported - ^DIK
+6 ; 10141 Supported - XPDUTL
+7 QUIT
+8 ;
POST ;post-install functions are coded here.
+1 ; 10141 Supported - XPDUTL
+2 DO BMES^XPDUTL(" Starting post-install of PSO*7*421")
+3 ; delete ALLOW ALL REJECTS & any 79/88 reject codes from file 52.86
DO DELAA
+4 DO BMES^XPDUTL(" Finished post-install of PSO*7*421")
+5 QUIT
+6 ;
DELAA ; This updates the 52.86 file - EPHARMACY SITE PARAMETERS
+1 ; It will delete ALLOW ALL REJECTS & any 79/88 reject codes
+2 ;
+3 ; Delete the ALLOW ALL REJECTS data first
+4 ; Loop through all entries and delete data from node 0 piece 2
+5 NEW IEN,RCIEN,DA,DIK
SET IEN=0
+6 FOR
SET IEN=$ORDER(^PS(52.86,IEN))
if 'IEN
QUIT
Begin DoDot:1
+7 ;
+8 ; Delete any data in node 0 piece 2 as it is no longer used
+9 SET $PIECE(^PS(52.86,IEN,0),U,2)=""
+10 ;
+11 ; delete any Transfer Reject codes with a value of 79
+12 IF $DATA(^PS(52.86,IEN,1,"B",79))
Begin DoDot:2
+13 SET RCIEN=0
+14 FOR
SET RCIEN=$ORDER(^PS(52.86,IEN,1,"B",79,RCIEN))
if 'RCIEN
QUIT
Begin DoDot:3
+15 KILL DA,DIK
SET DA=RCIEN
SET DA(1)=IEN
SET DIK="^PS(52.86,"_IEN_",1,"
DO ^DIK
End DoDot:3
End DoDot:2
+16 ;
+17 ; delete any Transfer Reject codes with a value of 88
+18 IF $DATA(^PS(52.86,IEN,1,"B",88))
Begin DoDot:2
+19 SET RCIEN=0
+20 FOR
SET RCIEN=$ORDER(^PS(52.86,IEN,1,"B",88,RCIEN))
if 'RCIEN
QUIT
Begin DoDot:3
+21 KILL DA,DIK
SET DA=RCIEN
SET DA(1)=IEN
SET DIK="^PS(52.86,"_IEN_",1,"
DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
+23 ; Once the ALLOW ALL REJECTS data is deleted,
+24 ; Delete the ALLOW ALL REJECTS field from the dictionary
+25 ; 10013 Supported - ^DIK
+26 SET DIK="^DD(52.86,"
SET DA=1
SET DA(1)=52.86
DO ^DIK
+27 ; 10141 Supported - XPDUTL
+28 ; Send a message confirming the field deletion
+29 DO MES^XPDUTL("ALLOW ALL REJECT field (#1) has been deleted from")
+30 DO MES^XPDUTL("the EPHARMACY SITE PARAMETERS file (52.86)")
+31 QUIT
