Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMRCYP5

GMRCYP5.m

Go to the documentation of this file. 
  1. GMRCYP5 ;SLC/DLT - Consult patch 5 pre-init ;9/8/98  03:52
  1.  ;;3.0;CONSULT/REQUEST TRACKING;**5**;DEC 27, 1997
  1.  ;
  1. EN ;Load protocols in GMRCR namespace into the PROCEDURE TYPE multiple
  1.  D BMES^XPDUTL("** Begin loading GMRCR Protocols into File 123 PROCEDURE TYPE multiple based on the FILE LINK service **")
  1.  N DA,PNM,PCNT,LCNT,OCNT,SNM,FL,DIC
  1.  S PNM="GMRCR",(LCNT,PCNT,OCNT,BCNT)=0
  1.  S GMRCPKG=$$FIND1^DIC(9.4,,"X","CONSULT/REQUEST TRACKING") I 'GMRCPKG D
  1.  . D BMES^XPDUTL("Unable to find entry for CONSULT/REQUEST TRACKING in PACKAGE (#9.4) file")
  1.  F  S PNM=$O(^ORD(101,"B",PNM)) Q:$E(PNM,1,5)'="GMRCR"  D
  1.  . S PIEN=$O(^ORD(101,"B",PNM,0)) Q:'PIEN  D
  1.  .. D SETFL
  1.  .. D SETPKG
  1.  .. D DISABLD
  1.  D BMES^XPDUTL("Total # of GMRCR protocols reviewed in protocol file: "_PCNT)
  1.  D BMES^XPDUTL("Total # of GMRCR protocols already added to a service in file 123.5: "_OCNT)
  1.  D BMES^XPDUTL("Total # of GMRCR protocols successfully added to a service in file 123.5: "_LCNT)
  1.  D BMES^XPDUTL("** Total # of GMRCR protocols Needing Review: "_BCNT)
  1.  D BMES^XPDUTL("** Finished GMRCR Protocol File Link Processing **")
  1.  D DELDUPS
  1.  Q
  1. SETFL ;Setup the protocol procedures in the service file based on FILE LINK
  1.  S PCNT=PCNT+1
  1.  S FL=$P($G(^ORD(101,+PIEN,5)),U,1)
  1.  I +$O(^GMR(123.5,"APR",+PIEN,+FL,0)) S OCNT=OCNT+1 Q
  1.  I '$D(^GMR(123.5,+FL,0)) D  Q
  1.  . I $E(PNM,1,7)="GMRCRM " D BMES^XPDUTL("Protocol menu "_PNM_" ignored - OK") Q
  1.  . 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
  1.  S SNM=$P($G(^GMR(123.5,+FL,0)),U,1)
  1.  S Y=$$FILE101(+FL,PIEN)
  1.  I +$G(Y)'>0 D BMES^XPDUTL("Unsuccessful add of Procedure "_PNM_" to file123.5") S BCNT=BCNT+1 Q
  1.  D BMES^XPDUTL("Procedure "_PNM_" successfully added to "_SNM_" service in file 123.5")
  1.  S LCNT=LCNT+1
  1.  Q
  1. FILE101(SVC,X) ;load the protocol entry as a PROCEDURE TYPE for the service
  1.  N DA,DIC,DLAYGO,Y
  1.  K DD,DO
  1.  S DA(1)=+SVC
  1.  S DIC="^GMR(123.5,"_DA(1)_",101,"
  1.  S DIC(0)="FL",X="`"_X
  1.  S DIC("P")=$P(^DD(123.5,101,0),U,2)
  1.  D ^DIC
  1.  Q $G(Y)
  1.  ;
  1. DELPROC ;Delete protocols from 123.5 and start over.
  1.  S PIEN=0
  1.  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
  1.  . S DA=0
  1.  . F  S DA=$O(^GMR(123.5,"APR",PIEN,DA(1),0)) Q:'DA  D
  1.  . . S DIK="^GMR(123.5,"_DA(1)_",101,"
  1.  . . D ^DIK
  1.  Q
  1. SETPKG ;reset PACKAGE field if not set
  1.  I $D(^ORD(101,PIEN,0)) D
  1.  . Q:$P(^ORD(101,PIEN,0),U,12)=GMRCPKG
  1.  . S $P(^ORD(101,PIEN,0),U,12)=GMRCPKG
  1.  Q
  1. DISABLD ;clear inadvertant DISABLE flag
  1.  I $D(^ORD(101,PIEN,0)) D
  1.  . I $P(^ORD(101,PIEN,0),U,3)=0 S $P(^(0),U,3)=""
  1.  Q
  1. DELDUPS ;clean up duplicate entries in PROCEDURE TYPE multiple
  1.  N SERV,IEN,DUP,PROC
  1.  D BMES^XPDUTL("Checking services for duplicate PROCEDURE TYPES")
  1.  S SERV=0 F  S SERV=$O(^GMR(123.5,SERV)) Q:'SERV  D
  1.  . Q:'$D(^GMR(123.5,SERV,101))
  1.  . S PROC=0 F  S PROC=$O(^GMR(123.5,SERV,101,"B",PROC)) Q:'PROC  D
  1.  .. S IEN=$O(^GMR(123.5,SERV,101,"B",PROC,0)) D
  1.  ... Q:'$O(^GMR(123.5,SERV,101,"B",PROC,IEN))
  1.  ... D BMES^XPDUTL(".")
  1.  ... S DUP=IEN F  S DUP=$O(^GMR(123.5,SERV,101,"B",PROC,DUP)) Q:'DUP  D
  1.  .... N DIK,DA,DA1
  1.  .... S DA(1)=SERV,DA=DUP,DIK="^GMR(123.5,"_DA(1)_",101,"
  1.  .... D ^DIK
  1.  Q