- 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 Feb 18, 2025@23:26:07 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