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

RORUTL07.m

Go to the documentation of this file. 
  1. RORUTL07 ;HCIOFO/SG - TEST ENTRY POINTS ; 26 May 2015  3:44 PM
  1.  ;;1.5;CLINICAL CASE REGISTRIES;**21,26**;Feb 17, 2006;Build 53
  1.  ;
  1.  Q
  1.  ;******************************************************************************
  1.  ;******************************************************************************
  1.  ;                       --- ROUTINE MODIFICATION LOG ---
  1.  ;        
  1.  ;PKG/PATCH    DATE        DEVELOPER    MODIFICATION
  1.  ;-----------  ----------  -----------  ----------------------------------------
  1.  ;ROR*1.5*26   APR  2015   T KOPP       UPDATE updated to ask for start date
  1.  ;                                      and set IO variable 
  1.  ;
  1.  ;******************************************************************************
  1.  ;******************************************************************************
  1.  ;
  1.  ;***** DISPLAYS THE ERRORS
  1. ERROR ;
  1.  D DSPSTK^RORERR()
  1.  Q
  1.  ;
  1.  ;***** DATA EXTRACTION TEST ENTRY POINT
  1. EXTRACT ;
  1.  N RORERRDL      ; Default error location
  1.  N RORERROR      ; Error processing data
  1.  N RORPARM       ; Application parameters
  1.  ;
  1.  N RC,REGLST,REGNAME,SDT
  1.  W !,"DATA EXTRACTION & TRANSMISSION IN DEBUG MODE",!
  1.  D KILL^XUSCLEAN
  1.  S RORPARM("DEBUG")=2
  1.  S RORPARM("ERR")=1
  1.  D CLEAR^RORERR("EXTRACT^RORUTL07")
  1.  ;--- Select registries
  1.  Q:$$SELREG(.REGLST)'>0
  1.  ;--- Request a start date
  1.  S SDT=$$GETSDT()                            G:SDT<0 ERROR
  1.  ;--- Extract the registry data
  1.  S RC=$$EXTRACT^ROREXT(.REGLST,SDT,,"S")  G:RC<0 ERROR
  1.  Q
  1.  ;
  1.  ;***** REQESTS A START DATE FROM A USER
  1.  ;
  1.  ; Return Values:
  1.  ;       <0  Error Code
  1.  ;       ""  No start date (default)
  1.  ;       >0  Start date
  1.  ;
  1. GETSDT() ;
  1.  ;;If you enter an empty string then the individual start date
  1.  ;;(from the registry record) will be used for each patient.
  1.  ;
  1.  N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,RC,X,Y
  1.  S DIR(0)="DO^:DT:EX"
  1.  S DIR("A")="Start date for data extraction"
  1.  F X=1:1  S Y=$P($T(GETSDT+X),";;",2)  Q:Y=""  S DIR("?",X)=Y
  1.  S DIR("?")="This response must be a date."
  1.  D ^DIR
  1.  S RC=$S($D(DTOUT):-72,$D(DUOUT):-71,1:0)
  1.  Q $S(RC<0:RC,1:$G(Y))
  1.  ;
  1.  ;***** SELECTS REGISTRIES FROM THE FILE #798.1
  1.  ;
  1.  ; .REGLST       Reference to a local variable for the list of
  1.  ;               registry names (subscripts) and IENs (values)
  1.  ;
  1.  ; Return Values:
  1.  ;       <0  Error code
  1.  ;        0  Nothing selected
  1.  ;       >0  Number of selected registries
  1.  ;       ""  Timeout or "^"
  1.  ;
  1. SELREG(REGLST) ;
  1.  N CNT,DA,DIC,DLAYGO,DTOUT,DUOUT,X,Y
  1.  K REGLST  S CNT=0
  1.  ;--- Select a registry
  1.  S DIC=798.1,DIC(0)="AENQ"
  1.  S DIC("A")="Select a Registry: "
  1.  F  D  Q:Y'>0  S REGLST($P(Y,U,2))=+Y,CNT=CNT+1
  1.  . D ^DIC
  1.  W !
  1.  Q $S($D(DTOUT)!$D(DUOUT):"",1:CNT)
  1.  ;
  1.  ;***** REGISTRY UPDATE TEST ENTRY POINT
  1. UPDATE ;
  1.  N RORERRDL      ; Default error location
  1.  N RORERROR      ; Error processing data
  1.  N RORPARM       ; Application parameters
  1.  ;
  1.  N RC,REGLST,REGNAME,DSBEG
  1.  D HOME^%ZIS
  1.  W !,"REGISTRY UPDATE IN DEBUG MODE",!
  1.  D KILL^XUSCLEAN
  1.  S RORPARM("DEBUG")=2
  1.  S RORPARM("ERR")=1
  1.  D CLEAR^RORERR("UPDATE^RORUTL07")
  1.  ;--- Select registries
  1.  Q:$$SELREG(.REGLST)'>0
  1.  ;--- Request a start date
  1.  S DSBEG=$$GETSDT()
  1.  Q:DSBEG<0
  1.  ;--- Update the registry
  1.  S RC=$$UPDATE^RORUPD(.REGLST)  G:RC<0 ERROR
  1.  Q
  1.   ;DEFINE ENTRY POINT TO CLEAR AND RESTART REGISTRY UPDATE
  1. DEL(REGLST) ;
  1.  ;Select new registry to delete
  1.  ;delete any records in 798 for that registry
  1.  ;delete enable protocols,hdt,registry updated until
  1.  N REGNAME,REGIEN,IEN,DA,DIK,RORFDA,IENS,RORMSG,DIERR
  1.  N FILE,ROOT,IX,RORPARM,FLD
  1.  S (REGNAME,IEN)=""
  1.  S RORPARM("DEVELOPER")=1
  1.  F  S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME=""  D
  1.  . S REGIEN=$$REGIEN^RORUTL02(REGNAME) Q:REGIEN=""
  1.  . ; Only local registries
  1.  . Q:$P($G(^ROR(798.1,REGIEN,0)),U,11)
  1.  . S IENS=REGIEN_","
  1.  . F FLD=6.1,6.2,7,10,13,13.1,19.1,19.2,19.3,21.01,21.04,21.05 D
  1.  . . S RORFDA(798.1,IENS,FLD)="@"
  1.  . S RORFDA(798.1,IENS,1)=2850101
  1.  . D FILE^DIE(,"RORFDA","RORMSG")
  1.  . I $G(DIERR) W !!,"<<ERROR - restoring "_REGNAME_" registry parameters>>" Q
  1.  . F  S IEN=$O(^RORDATA(798,"AC",REGIEN,IEN)) Q:IEN=""  D
  1.  . . N DA,DIK
  1.  . . S DIK=$$ROOT^DILFD(798),DA=IEN  D ^DIK
  1.  . . W !,"<< "_IEN_" >> Deleted"
  1.  Q
  1.  ;