GMRCSUBS ;SLC/dee - Routine to check if a Service has more that one parient service ;1/18/00
;;3.0;CONSULT/REQUEST TRACKING;**7**;DEC 27, 1997
;
Q
EN ;Check the service hierarchy (file #123.5) for services
; that have more than are in more than one grouper.
N SERVICE,PARENT,COUNT,NUMBER
S NUMBER=0
;$Order though all Services
S SERVICE=0
F S SERVICE=$O(^GMR(123.5,SERVICE)) Q:'+SERVICE D
. S PARENT=0
. ;Check if they are a subservice to more than one service.
. F COUNT=0:1 S PARENT=$O(^GMR(123.5,"APC",SERVICE,PARENT)) Q:'+PARENT D
.. ;
. ;Print message about which services this service is a subservice of.
. I COUNT>1 D
.. W !,"Service ",$P(^GMR(123.5,SERVICE,0),"^",1)," is a sub service of:"
.. S PARENT=0
.. F S PARENT=$O(^GMR(123.5,"APC",SERVICE,PARENT)) Q:'+PARENT W !," ",$P(^GMR(123.5,PARENT,0),"^",1)
.. S NUMBER=NUMBER+1
;Print totals.
I NUMBER=0 W !!,"No Services are sub-services for more than one service."
E I NUMBER=1 W !!,"There is ",NUMBER," service that is a sub-service for more than one service."
E W !!,"There are ",NUMBER," services that are sub-services for more than one service."
Q
;
CLEANAE ;Post-init for patch GMRC*3*7
;This will delete the AE cross-reference and then rebuild it.
;This is to make sure that the AE cross-reference does not contain
; any bad entries.
N DIK
K ^GMR(123,"AE")
S DIK="^GMR(123,",DIK(1)="1^AE"
D ENALL^DIK
Q
;
POST ;Post install routine for patch 7
D BMES^XPDUTL("Running POST^GMRCSUBS")
D CLEANAE
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCSUBS 1551 printed Nov 22, 2024@16:57:43 Page 2
GMRCSUBS ;SLC/dee - Routine to check if a Service has more that one parient service ;1/18/00
+1 ;;3.0;CONSULT/REQUEST TRACKING;**7**;DEC 27, 1997
+2 ;
+3 QUIT
EN ;Check the service hierarchy (file #123.5) for services
+1 ; that have more than are in more than one grouper.
+2 NEW SERVICE,PARENT,COUNT,NUMBER
+3 SET NUMBER=0
+4 ;$Order though all Services
+5 SET SERVICE=0
+6 FOR
SET SERVICE=$ORDER(^GMR(123.5,SERVICE))
if '+SERVICE
QUIT
Begin DoDot:1
+7 SET PARENT=0
+8 ;Check if they are a subservice to more than one service.
+9 FOR COUNT=0:1
SET PARENT=$ORDER(^GMR(123.5,"APC",SERVICE,PARENT))
if '+PARENT
QUIT
Begin DoDot:2
+10 ;
End DoDot:2
+11 ;Print message about which services this service is a subservice of.
+12 IF COUNT>1
Begin DoDot:2
+13 WRITE !,"Service ",$PIECE(^GMR(123.5,SERVICE,0),"^",1)," is a sub service of:"
+14 SET PARENT=0
+15 FOR
SET PARENT=$ORDER(^GMR(123.5,"APC",SERVICE,PARENT))
if '+PARENT
QUIT
WRITE !," ",$PIECE(^GMR(123.5,PARENT,0),"^",1)
+16 SET NUMBER=NUMBER+1
End DoDot:2
End DoDot:1
+17 ;Print totals.
+18 IF NUMBER=0
WRITE !!,"No Services are sub-services for more than one service."
+19 IF '$TEST
IF NUMBER=1
WRITE !!,"There is ",NUMBER," service that is a sub-service for more than one service."
+20 IF '$TEST
WRITE !!,"There are ",NUMBER," services that are sub-services for more than one service."
+21 QUIT
+22 ;
CLEANAE ;Post-init for patch GMRC*3*7
+1 ;This will delete the AE cross-reference and then rebuild it.
+2 ;This is to make sure that the AE cross-reference does not contain
+3 ; any bad entries.
+4 NEW DIK
+5 KILL ^GMR(123,"AE")
+6 SET DIK="^GMR(123,"
SET DIK(1)="1^AE"
+7 DO ENALL^DIK
+8 QUIT
+9 ;
POST ;Post install routine for patch 7
+1 DO BMES^XPDUTL("Running POST^GMRCSUBS")
+2 DO CLEANAE
+3 QUIT
+4 ;
