GMRCYP5 ;SLC/DLT - Consult patch 5 pre-init ;9/8/98 03:52
;;3.0;CONSULT/REQUEST TRACKING;**5**;DEC 27, 1997
;
EN ;Load protocols in GMRCR namespace into the PROCEDURE TYPE multiple
D BMES^XPDUTL("** Begin loading GMRCR Protocols into File 123 PROCEDURE TYPE multiple based on the FILE LINK service **")
N DA,PNM,PCNT,LCNT,OCNT,SNM,FL,DIC
S PNM="GMRCR",(LCNT,PCNT,OCNT,BCNT)=0
S GMRCPKG=$$FIND1^DIC(9.4,,"X","CONSULT/REQUEST TRACKING") I 'GMRCPKG D
. D BMES^XPDUTL("Unable to find entry for CONSULT/REQUEST TRACKING in PACKAGE (#9.4) file")
F S PNM=$O(^ORD(101,"B",PNM)) Q:$E(PNM,1,5)'="GMRCR" D
. S PIEN=$O(^ORD(101,"B",PNM,0)) Q:'PIEN D
.. D SETFL
.. D SETPKG
.. D DISABLD
D BMES^XPDUTL("Total # of GMRCR protocols reviewed in protocol file: "_PCNT)
D BMES^XPDUTL("Total # of GMRCR protocols already added to a service in file 123.5: "_OCNT)
D BMES^XPDUTL("Total # of GMRCR protocols successfully added to a service in file 123.5: "_LCNT)
D BMES^XPDUTL("** Total # of GMRCR protocols Needing Review: "_BCNT)
D BMES^XPDUTL("** Finished GMRCR Protocol File Link Processing **")
D DELDUPS
Q
SETFL ;Setup the protocol procedures in the service file based on FILE LINK
S PCNT=PCNT+1
S FL=$P($G(^ORD(101,+PIEN,5)),U,1)
I +$O(^GMR(123.5,"APR",+PIEN,+FL,0)) S OCNT=OCNT+1 Q
I '$D(^GMR(123.5,+FL,0)) D Q
. I $E(PNM,1,7)="GMRCRM " D BMES^XPDUTL("Protocol menu "_PNM_" ignored - OK") Q
. D BMES^XPDUTL("Protocol "_PNM_" contains an invalid service (FILE LINK "_$S($L(FL):FL,1:"not defined")_") - ** needs review") S BCNT=BCNT+1 Q
S SNM=$P($G(^GMR(123.5,+FL,0)),U,1)
S Y=$$FILE101(+FL,PIEN)
I +$G(Y)'>0 D BMES^XPDUTL("Unsuccessful add of Procedure "_PNM_" to file123.5") S BCNT=BCNT+1 Q
D BMES^XPDUTL("Procedure "_PNM_" successfully added to "_SNM_" service in file 123.5")
S LCNT=LCNT+1
Q
FILE101(SVC,X) ;load the protocol entry as a PROCEDURE TYPE for the service
N DA,DIC,DLAYGO,Y
K DD,DO
S DA(1)=+SVC
S DIC="^GMR(123.5,"_DA(1)_",101,"
S DIC(0)="FL",X="`"_X
S DIC("P")=$P(^DD(123.5,101,0),U,2)
D ^DIC
Q $G(Y)
;
DELPROC ;Delete protocols from 123.5 and start over.
S PIEN=0
F S PIEN=$O(^GMR(123.5,"APR",PIEN)) Q:'PIEN S DA(1)=0 F S DA(1)=$O(^GMR(123.5,"APR",PIEN,DA(1))) Q:'DA(1) D
. S DA=0
. F S DA=$O(^GMR(123.5,"APR",PIEN,DA(1),0)) Q:'DA D
. . S DIK="^GMR(123.5,"_DA(1)_",101,"
. . D ^DIK
Q
SETPKG ;reset PACKAGE field if not set
I $D(^ORD(101,PIEN,0)) D
. Q:$P(^ORD(101,PIEN,0),U,12)=GMRCPKG
. S $P(^ORD(101,PIEN,0),U,12)=GMRCPKG
Q
DISABLD ;clear inadvertant DISABLE flag
I $D(^ORD(101,PIEN,0)) D
. I $P(^ORD(101,PIEN,0),U,3)=0 S $P(^(0),U,3)=""
Q
DELDUPS ;clean up duplicate entries in PROCEDURE TYPE multiple
N SERV,IEN,DUP,PROC
D BMES^XPDUTL("Checking services for duplicate PROCEDURE TYPES")
S SERV=0 F S SERV=$O(^GMR(123.5,SERV)) Q:'SERV D
. Q:'$D(^GMR(123.5,SERV,101))
. S PROC=0 F S PROC=$O(^GMR(123.5,SERV,101,"B",PROC)) Q:'PROC D
.. S IEN=$O(^GMR(123.5,SERV,101,"B",PROC,0)) D
... Q:'$O(^GMR(123.5,SERV,101,"B",PROC,IEN))
... D BMES^XPDUTL(".")
... S DUP=IEN F S DUP=$O(^GMR(123.5,SERV,101,"B",PROC,DUP)) Q:'DUP D
.... N DIK,DA,DA1
.... S DA(1)=SERV,DA=DUP,DIK="^GMR(123.5,"_DA(1)_",101,"
.... D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCYP5 3266 printed Sep 23, 2025@19:23:59 Page 2
GMRCYP5 ;SLC/DLT - Consult patch 5 pre-init ;9/8/98 03:52
+1 ;;3.0;CONSULT/REQUEST TRACKING;**5**;DEC 27, 1997
+2 ;
EN ;Load protocols in GMRCR namespace into the PROCEDURE TYPE multiple
+1 DO BMES^XPDUTL("** Begin loading GMRCR Protocols into File 123 PROCEDURE TYPE multiple based on the FILE LINK service **")
+2 NEW DA,PNM,PCNT,LCNT,OCNT,SNM,FL,DIC
+3 SET PNM="GMRCR"
SET (LCNT,PCNT,OCNT,BCNT)=0
+4 SET GMRCPKG=$$FIND1^DIC(9.4,,"X","CONSULT/REQUEST TRACKING")
IF 'GMRCPKG
Begin DoDot:1
+5 DO BMES^XPDUTL("Unable to find entry for CONSULT/REQUEST TRACKING in PACKAGE (#9.4) file")
End DoDot:1
+6 FOR
SET PNM=$ORDER(^ORD(101,"B",PNM))
if $EXTRACT(PNM,1,5)'="GMRCR"
QUIT
Begin DoDot:1
+7 SET PIEN=$ORDER(^ORD(101,"B",PNM,0))
if 'PIEN
QUIT
Begin DoDot:2
+8 DO SETFL
+9 DO SETPKG
+10 DO DISABLD
End DoDot:2
End DoDot:1
+11 DO BMES^XPDUTL("Total # of GMRCR protocols reviewed in protocol file: "_PCNT)
+12 DO BMES^XPDUTL("Total # of GMRCR protocols already added to a service in file 123.5: "_OCNT)
+13 DO BMES^XPDUTL("Total # of GMRCR protocols successfully added to a service in file 123.5: "_LCNT)
+14 DO BMES^XPDUTL("** Total # of GMRCR protocols Needing Review: "_BCNT)
+15 DO BMES^XPDUTL("** Finished GMRCR Protocol File Link Processing **")
+16 DO DELDUPS
+17 QUIT
SETFL ;Setup the protocol procedures in the service file based on FILE LINK
+1 SET PCNT=PCNT+1
+2 SET FL=$PIECE($GET(^ORD(101,+PIEN,5)),U,1)
+3 IF +$ORDER(^GMR(123.5,"APR",+PIEN,+FL,0))
SET OCNT=OCNT+1
QUIT
+4 IF '$DATA(^GMR(123.5,+FL,0))
Begin DoDot:1
+5 IF $EXTRACT(PNM,1,7)="GMRCRM "
DO BMES^XPDUTL("Protocol menu "_PNM_" ignored - OK")
QUIT
+6 DO BMES^XPDUTL("Protocol "_PNM_" contains an invalid service (FILE LINK "_$SELECT($LENGTH(FL):FL,1:"not defined")_") - ** needs review")
SET BCNT=BCNT+1
QUIT
End DoDot:1
QUIT
+7 SET SNM=$PIECE($GET(^GMR(123.5,+FL,0)),U,1)
+8 SET Y=$$FILE101(+FL,PIEN)
+9 IF +$GET(Y)'>0
DO BMES^XPDUTL("Unsuccessful add of Procedure "_PNM_" to file123.5")
SET BCNT=BCNT+1
QUIT
+10 DO BMES^XPDUTL("Procedure "_PNM_" successfully added to "_SNM_" service in file 123.5")
+11 SET LCNT=LCNT+1
+12 QUIT
FILE101(SVC,X) ;load the protocol entry as a PROCEDURE TYPE for the service
+1 NEW DA,DIC,DLAYGO,Y
+2 KILL DD,DO
+3 SET DA(1)=+SVC
+4 SET DIC="^GMR(123.5,"_DA(1)_",101,"
+5 SET DIC(0)="FL"
SET X="`"_X
+6 SET DIC("P")=$PIECE(^DD(123.5,101,0),U,2)
+7 DO ^DIC
+8 QUIT $GET(Y)
+9 ;
DELPROC ;Delete protocols from 123.5 and start over.
+1 SET PIEN=0
+2 FOR
SET PIEN=$ORDER(^GMR(123.5,"APR",PIEN))
if 'PIEN
QUIT
SET DA(1)=0
FOR
SET DA(1)=$ORDER(^GMR(123.5,"APR",PIEN,DA(1)))
if 'DA(1)
QUIT
Begin DoDot:1
+3 SET DA=0
+4 FOR
SET DA=$ORDER(^GMR(123.5,"APR",PIEN,DA(1),0))
if 'DA
QUIT
Begin DoDot:2
+5 SET DIK="^GMR(123.5,"_DA(1)_",101,"
+6 DO ^DIK
End DoDot:2
End DoDot:1
+7 QUIT
SETPKG ;reset PACKAGE field if not set
+1 IF $DATA(^ORD(101,PIEN,0))
Begin DoDot:1
+2 if $PIECE(^ORD(101,PIEN,0),U,12)=GMRCPKG
QUIT
+3 SET $PIECE(^ORD(101,PIEN,0),U,12)=GMRCPKG
End DoDot:1
+4 QUIT
DISABLD ;clear inadvertant DISABLE flag
+1 IF $DATA(^ORD(101,PIEN,0))
Begin DoDot:1
+2 IF $PIECE(^ORD(101,PIEN,0),U,3)=0
SET $PIECE(^(0),U,3)=""
End DoDot:1
+3 QUIT
DELDUPS ;clean up duplicate entries in PROCEDURE TYPE multiple
+1 NEW SERV,IEN,DUP,PROC
+2 DO BMES^XPDUTL("Checking services for duplicate PROCEDURE TYPES")
+3 SET SERV=0
FOR
SET SERV=$ORDER(^GMR(123.5,SERV))
if 'SERV
QUIT
Begin DoDot:1
+4 if '$DATA(^GMR(123.5,SERV,101))
QUIT
+5 SET PROC=0
FOR
SET PROC=$ORDER(^GMR(123.5,SERV,101,"B",PROC))
if 'PROC
QUIT
Begin DoDot:2
+6 SET IEN=$ORDER(^GMR(123.5,SERV,101,"B",PROC,0))
Begin DoDot:3
+7 if '$ORDER(^GMR(123.5,SERV,101,"B",PROC,IEN))
QUIT
+8 DO BMES^XPDUTL(".")
+9 SET DUP=IEN
FOR
SET DUP=$ORDER(^GMR(123.5,SERV,101,"B",PROC,DUP))
if 'DUP
QUIT
Begin DoDot:4
+10 NEW DIK,DA,DA1
+11 SET DA(1)=SERV
SET DA=DUP
SET DIK="^GMR(123.5,"_DA(1)_",101,"
+12 DO ^DIK
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
