PRC5167P ;OI&T/DDA - INSTALL UTILITY ROUTINE ;7/2/12 13:58
;;5.1;IFCAP;**167**;Oct 20, 2000;Build 17
;;Per VHA Directive 2004-38, this routine should not be modified.
;
Q
POST ; post install;
; ADD the two new eCMS related status entries
N PRCERR,PRCD4423
S PRCERR=""
S PRCD4423=1
S PRCIEN(1)=69
S PRC4423(442.3,"+1,",.01)="Sent to eCMS (P&C)"
S PRC4423(442.3,"+1,",.02)=69
D UPDATE^DIE("","PRC4423","PRCIEN","PRCERR")
;I $D(PRCERR)
K PRC4423,PRCIEN
S PRCIEN(1)=77
S PRC4423(442.3,"+1,",.01)="Returned to Service by eCMS (P&C)"
S PRC4423(442.3,"+1,",.02)=77
D UPDATE^DIE("","PRC4423","PRCIEN","PRCERR")
K PRC4423,PRCIEN
UPDT ; Update status 70 to new text
S PRC4423(442.3,"70,",.01)="To IFCAP Ordering Officer"
D FILE^DIE("","PRC4423","PRCERR")
K PRC4423
;
ID ; covered by ICR #5819
D MES^XPDUTL(" - Setting ID nodes for file #410 and subfile #410.02")
S ^DD(410,0,"ID","Z3")="D:$P($G(^(1)),U,8)]"""" EN^DDIOL(""Sent to eCMS"",,""?0""),EN^DDIOL("" "",,""!?2"")"
S ^DD(410.02,0,"ID","Z2")="D:$P($G(@(DIC_+Y_"",4)"")),U,3)]"""" EN^DDIOL(""eCMS Item Line ID ""_$P(^(4),U,3),,""!?10"")"
D MES^XPDUTL(" - ID nodes set")
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC5167P 1185 printed Sep 23, 2025@19:35:48 Page 2
PRC5167P ;OI&T/DDA - INSTALL UTILITY ROUTINE ;7/2/12 13:58
+1 ;;5.1;IFCAP;**167**;Oct 20, 2000;Build 17
+2 ;;Per VHA Directive 2004-38, this routine should not be modified.
+3 ;
+4 QUIT
POST ; post install;
+1 ; ADD the two new eCMS related status entries
+2 NEW PRCERR,PRCD4423
+3 SET PRCERR=""
+4 SET PRCD4423=1
+5 SET PRCIEN(1)=69
+6 SET PRC4423(442.3,"+1,",.01)="Sent to eCMS (P&C)"
+7 SET PRC4423(442.3,"+1,",.02)=69
+8 DO UPDATE^DIE("","PRC4423","PRCIEN","PRCERR")
+9 ;I $D(PRCERR)
+10 KILL PRC4423,PRCIEN
+11 SET PRCIEN(1)=77
+12 SET PRC4423(442.3,"+1,",.01)="Returned to Service by eCMS (P&C)"
+13 SET PRC4423(442.3,"+1,",.02)=77
+14 DO UPDATE^DIE("","PRC4423","PRCIEN","PRCERR")
+15 KILL PRC4423,PRCIEN
UPDT ; Update status 70 to new text
+1 SET PRC4423(442.3,"70,",.01)="To IFCAP Ordering Officer"
+2 DO FILE^DIE("","PRC4423","PRCERR")
+3 KILL PRC4423
+4 ;
ID ; covered by ICR #5819
+1 DO MES^XPDUTL(" - Setting ID nodes for file #410 and subfile #410.02")
+2 SET ^DD(410,0,"ID","Z3")="D:$P($G(^(1)),U,8)]"""" EN^DDIOL(""Sent to eCMS"",,""?0""),EN^DDIOL("" "",,""!?2"")"
+3 SET ^DD(410.02,0,"ID","Z2")="D:$P($G(@(DIC_+Y_"",4)"")),U,3)]"""" EN^DDIOL(""eCMS Item Line ID ""_$P(^(4),U,3),,""!?10"")"
+4 DO MES^XPDUTL(" - ID nodes set")
+5 ;
+6 QUIT
