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

GMRCDRFR.m

Go to the documentation of this file.
  1. GMRCDRFR ;SLC/JFR - DEFAULT REASON FOR REQUEST UTILS ; 11/12/00 12:00
  1. ;;3.0;CONSULT/REQUEST TRACKING;**12,15**;DEC 27, 1997
  1. ;
  1. ; This routine invokes IA #2876
  1. ;
  1. EN ; -- main entry point for GMRC DEFAULT REASON
  1. N GMRCSV,GMRCDFN,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT
  1. S DIR(0)="SOA^S:service;P:procedure"
  1. S DIR("A")="Test default for service or procedure? "
  1. D ^DIR I $D(DIRUT) Q
  1. I Y="S" D SELSS Q:'$D(GMRCSV)
  1. I Y="P" D SELPROC Q:'$D(GMRCPROC)
  1. D SELPT Q:'$D(GMRCPAT)
  1. D INIT
  1. D EN^VALM("GMRC DEFAULT REASON")
  1. Q
  1. ;
  1. SELPT ;get new patient
  1. N DIR,X,Y,DIRUT,DUOUT,DTOUT
  1. D FULL^VALM1
  1. S DIR(0)="PO^2:EQM" D ^DIR
  1. I $D(DIRUT) Q
  1. S GMRCPAT=+Y
  1. K ^TMP("GMRCRFR",$J)
  1. Q
  1. ;
  1. SELSS ; get new service
  1. N DIR,X,Y,DIRUT,DUOUT,DTOUT
  1. D FULL^VALM1
  1. K GMRCSV,GMRCPROC
  1. S DIR(0)="PO^123.5:EMQ",DIR("A")="Select Service"
  1. D ^DIR
  1. I $D(DIRUT) Q
  1. S GMRCSV=+Y_";99CON"
  1. K ^TMP("GMRCRFR",$J)
  1. Q
  1. ;
  1. SELPROC ; get a new procedure
  1. ;
  1. N DIR,X,Y,DIRUT,DUOUT,DTOUT
  1. D FULL^VALM1
  1. K GMRCSV,GMRCPROC
  1. S DIR(0)="PO^123.3:EMQ",DIR("A")="Select Procedure"
  1. D ^DIR
  1. I $D(DIRUT) Q
  1. S GMRCPROC=+Y_";99PRC"
  1. K ^TMP("GMRCRFR",$J)
  1. Q
  1. ;
  1. HDR ; -- header code
  1. I $D(GMRCPROC) S VALMHDR(1)="Procedure: "_$P(^GMR(123.3,+GMRCPROC,0),U)
  1. I $D(GMRCSV) S VALMHDR(1)="Service: "_$P(^GMR(123.5,+GMRCSV,0),U)
  1. S VALMHDR(2)="Patient: "_$$GET1^DIQ(2,+GMRCPAT,.01)
  1. Q
  1. ;
  1. INIT ; -- init variables and list array
  1. Q:$D(^TMP("GMRCRFR",$J))
  1. D GETDEF($NA(^TMP("GMRCRFR",$J)),$S($D(GMRCSV):GMRCSV,1:GMRCPROC),GMRCPAT,1)
  1. I '$D(^TMP("GMRCRFR",$J)) D
  1. . S ^TMP("GMRCRFR",$J,1,0)="No default Reason for Request exists for the selected item."
  1. S VALMCNT=$O(^TMP("GMRCRFR",$J,999999),-1)
  1. S VALMBG=1
  1. Q
  1. ;
  1. HELP ; -- help code
  1. S X="?" D DISP^XQORM1 W !!
  1. Q
  1. ;
  1. EXIT ; -- exit code
  1. K GMRCSV,GMRCPAT,GMRCPROC
  1. Q
  1. ;
  1. EXPND ; -- expand code
  1. Q
  1. ;
  1. GETDEF(GMRCARR,GMRCSRV,GMRCDFN,RESOLV) ; return default reason for request
  1. ; GMRCARR = array to return containing default RFR
  1. ; GMRCSRV = reference to file 123.5 (#;99CON) or file 123.3 (#;99PRC)
  1. ; GMRCDFN = patient identifier if to return resolved
  1. ; RESOLV = 1 or 0 ; if RESOLV=1 GMRCARR will be returned resolved
  1. Q:'+GMRCSRV
  1. N GMRCFIL
  1. S GMRCFIL=$S(GMRCSRV[";99PRC":123.3,1:123.5)
  1. Q:'$D(^GMR(GMRCFIL,+GMRCSRV,124))
  1. I '$D(GMRCDFN)!('$G(RESOLV)) D Q
  1. . M @GMRCARR=^GMR(GMRCFIL,+GMRCSRV,124)
  1. D BLRPLT^TIUSRVD(,,GMRCDFN,,$NA(^GMR(GMRCFIL,+GMRCSRV,124)))
  1. I $D(^TMP("TIUBOIL",$J)) M @GMRCARR=^TMP("TIUBOIL",$J)
  1. K ^TMP("TIUBOIL",$J)
  1. Q
  1. REAF(GMRCOI) ;return value of RESTRICT DEFAULT REASON EDIT field to CPRS
  1. ;Input:
  1. ; GMRCOI - ref to file 123.5 (ien;99CON) or file 123.3 (ien;99PRC)
  1. ;Output:
  1. ; Integer 0 - unrestricted
  1. ; 1 - ask on edit only
  1. ; 2 - no editing
  1. ;
  1. N FILE
  1. S FILE=$S(GMRCOI["99PRC":123.3,1:123.5)
  1. I '$O(^GMR(FILE,+GMRCOI,124,0)) Q 0
  1. I FILE=123.5 Q +$P($G(^GMR(FILE,+GMRCOI,1)),U,3) ;cslt service
  1. Q +$P($G(^GMR(FILE,+GMRCOI,0)),U,9) ;procedure