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

DGUTL.m

Go to the documentation of this file. 
  1. DGUTL ;ALB/MRL - DG UTILITY FUNCTIONS ; 08 JAN 86
  1.  ;;5.3;Registration;**279,570,677,1015**;Aug 13, 1993;Build 21
  1.  ;
  1. RI ;Reimbursable Insurance
  1.  ; ** NOTE: This procedure appears to be obsolete, but code was modified
  1.  ; for IB/AR Encapsulation anyways.
  1.  Q  ;ihs/cmi/maw 02/08/2012 patch 1014 no IB
  1.  S DGINS=$$INSUR^IBBAPI(DFN,"","A")
  1.  Q
  1.  ;
  1. TS ;Table of Contents SET
  1.  I '$D(^UTILITY($J,"DGTC",DGPAG)) S ^UTILITY($J,"DGTC",DGPAG,DGPAG1)="" Q
  1. TP ;Table of Contents PRINT
  1.  I '$D(^UTILITY($J,"DGTC")) Q
  1.  D TH S J=0 F I=0:0 S J=$O(^UTILITY($J,"DGTC",J)),J1=0 Q:J=""  F I1=0:0 S J1=$O(^UTILITY($J,"DGTC",J,J1)) Q:J1=""  S X="",$P(X,".",(IOM-20-$L(J)-$L(J1)))="" W !?10,J,"  ",X,"  ",J1 I $Y>$S($D(IOSL):(IOSL-6),1:62) D TH
  1.  W ! K ^UTILITY($J,"DGTC"),I,I1,J,J1,DGTCH,X,Y Q
  1. TH ;Table of Contents HEADER
  1.  W @IOF,!,"TABLE OF CONTENTS FOR '",$P(DGTCH,U,1),"'",?(IOM-11) S Y=DT X ^DD("DD") W Y,!?10,$P(DGTCH,U,2),?IOM-7-$L($P(DGTCH,U,3)),$P(DGTCH,U,3) S X="",$P(X,"=",IOM)="" W !,X K X Q
  1. C ;Cover Page
  1.  W @IOF S TT=0 F I=0:0 S I=$O(DGCPG(I)) Q:'I  S TT=TT+1,$P(DGCPG(I),U,2)=$S($D(IOM):IOM-$L($P(DGCPG(I),U,1))\2,1:132-$L($P(DGCPG(I),U,1))\2)
  1.  S TT=$S($D(IOSL):IOSL-(TT*2+10)\2,1:66-(TT*2+10)\2) F I=1:1:TT W !
  1.  F I=0:0 S I=$O(DGCPG(I)) Q:'I  W !!?$P(DGCPG(I),U,2),$P(DGCPG(I),U,1)
  1.  I $D(DUZ),$D(^VA(200,+DUZ,0)) S X="Printed by:  "_$P(^(0),U,1),X1=$S($D(IOM):IOM-$L(X)\2,1:132-$L(X)\2) W !!?X1,X
  1.  I $D(^DD("SITE"))#2 S X=^("SITE")_" ("_^("SITE",1)_")",X1=$S($D(IOM):IOM-$L(X)\2,1:132-$L(X)\2) W !!?X1,X
  1.  I $D(DGCPT) X "F I=1:1:$S($D(IOSL):(IOSL-5),1:61)-$Y W !" W DGCPT
  1.  W !! K TT,I,X,X1 Q
  1. H ;Convert $H to Readable Date/Time
  1.  D:'$D(DT) DT^DICRW S DGTIME=$P($H,",",2),DGTIME=DT+(DGTIME\3600/100)+(DGTIME\60#60/10000),DGDATE=DGTIME\1 Q
  1. DIV ;Determine Division
  1.  I $D(^DG(43,1,"GL")),$P(^("GL"),"^",2) S DGDIV="" Q
  1.  S DGDIV=$S($O(^DG(40.8,0))>0:$O(^DG(40.8,0)),1:"") I DGDIV S DGDIV=DGDIV_"^"_$P(^DG(40.8,+DGDIV,0),"^",1)
  1.  Q
  1. DT W:$E(%,4,5) +$E(%,4,5)_"-" W:$E(%,6,7) +$E(%,6,7)_"-" W $E(%,1,3)+1700 W:%["." " ("_$E(%_0,9,10)_":"_$E(%_"000",11,12)_")" Q
  1. EOM ;Required Variable: X - Date should be in internal FM date format
  1.  ;Returned Variable: Y - End of Month in internal FM date format
  1.  S X1=$S($E(X,4,5)=12:$E(X,1,3)+1_"01",1:$E(X,1,5)+1)_"01"_$S($P(X,".",2):"."_$P(X,".",2),1:""),X2=-1 D C^%DTC S Y=X K X
  1.  Q
  1. LO D:'$D(DT) DT^DICRW S:'$D(DTIME) DTIME=300 S U="^" Q
  1.  I '$D(^DG(43,1,0)) W !,"ADT parameters not set up",*7 G H^XUS
  1.  S USER=$S($D(DUZ)#10:DUZ,1:0) I 'USER!('$D(^VA(200,USER,0))) W !!,"Please log off the computer and then back to use this option.",!!,*7 K ^UTILITY("DG",$J) G H^XUS
  1.  K USER Q
  1.  ;
  1. UPPER(X) ; -- convert to uppercase
  1.  Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  ;
  1. LOWER(X) ;
  1.  N Y,C,Z,I
  1.  S Y=$E(X)_$TR($E(X,2,999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ@","abcdefghijklmnopqrstuvwxyz ")
  1.  F C=" ",",","/" F I=2:1 S Z=$P(Y,C,I,999) Q:Z=""  S Y=$P(Y,C,1,I-1)_C_$TR($E(Z),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$E(Z,2,999)
  1.  Q Y
  1. QUES(DFN,DGQCODE) ; EDIT REGISTRATION DATA FOR AMIE USE ONLY
  1.  ;
  1.  ;  INPUT:
  1.  ;     DFN
  1.  ;     DGQCODE = Code for question(s) to be asked
  1.  ;  OUTPUT:
  1.  ;     DGERR   = ERROR VARIABLE
  1.  ;     DGCHANGE= 1 IF DATA MODIFIED 0 O/W
  1.  ;
  1.  N D,D0,DI,DIC,DGCODE,DGDR,DGNODE,DGQNODES,DGPC,DGPTND,DGRPS,DGQ,DGX,DQ,N,X,Y,%Y
  1.  S (DGERR,DGRPS,DGCHANGE)=0
  1.  G:'($G(DFN)&($G(DGQCODE)="ADD1")) QTE
  1.  S DGPC=2,DGCODE="ADD1"
  1.  S DGDR=104
  1.  S DGRPS=1
  1.  S DGQNODES=".11~.13"
  1.  F N=1:1 S DGNODE=$P(DGQNODES,"~",N) Q:DGNODE']""  S DGPTND(DGNODE)=$G(^DPT(DFN,DGNODE))
  1.  D ^DGRPE
  1.  F DGNODE=0:0 S DGNODE=$O(DGPTND(DGNODE)) Q:DGNODE']""  S:$G(^DPT(DFN,DGNODE))'=(DGPTND(DGNODE)) DGCHANGE=1
  1. QTE I 'DGRPS S DGERR=1
  1. QTQ Q
  1.  ;FORM FEED & STOPPING UTILITIES
  1. FIRST() ;First heading of report
  1.  ; RETURNS STOP; 0=GO,1=STOP
  1.  N STOP
  1.  D STOPCHK
  1.  D:$G(STOP) STOPPED
  1.  I '$G(STOP),$E($G(IOST),1,2)="C-" W @IOF
  1.  Q $G(STOP)
  1.  ;
  1. SUBSEQ() ;enter for further headings of report
  1.  ; RETURNS STOP; 0=GO,1=STOP
  1.  N STOP,DIR,X,Y
  1.  D STOPCHK
  1.  I $E($G(IOST),1,2)="C-" S DIR(0)="E" D ^DIR S:$D(DIRUT) STOP=1
  1.  D:$G(STOP) STOPPED
  1.  I '$G(STOP) W @IOF
  1.  Q $G(STOP)
  1.  ;
  1. STOPCHK I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,STOP)=1
  1.  Q
  1. STOPPED ;
  1.  W !?5,"------------- Report stopped at user's request ------------"
  1.  K ZTREQ
  1.  Q
  1. ENDREP I $E(IOST,1,2)'["C-" W:$Y&'$D(IONOFF) @IOF Q
  1.  Q
  1.  ;
  1. ASKDIV(NOTALL) ;Ask for division (one/many/all)
  1.  ; Input: NOTALL - Flag that prevents selection of all divisions
  1.  ;          1 = Don't allow selection of all divisions
  1.  ;          0 = Allow selection of all divisions (default)
  1.  ;Output: Integer indicating if selection was made
  1.  ;          0 = No divisions selected (user quit)
  1.  ;          1 = Divisions selected
  1.  ;        VAUTD will be set as follows:
  1.  ;          VAUTD = 1 if all divisions selected
  1.  ;          VAUTD = 0 if individual divisions selected
  1.  ;          VAUTD(DivPtr) = DivisionName for each division selected
  1.  ; Notes: VAUTD is KILLed in input
  1.  ;
  1.  N FIRSTDIV,MULTIDIV,Y,VAUTNALL
  1.  K VAUTD
  1.  S FIRSTDIV=+$O(^DG(40.80,0))
  1.  I '$D(^DG(40.8,FIRSTDIV,0)) D  G ASKDIVQ
  1.  . W !
  1.  . W $C(7),"***WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP***"
  1.  . W !
  1.  S MULTIDIV=+$P($G(^DG(43,1,"GL")),"^",2)
  1.  I 'MULTIDIV S VAUTD=1 G ASKDIVQ
  1.  S (VAUTD,Y)=0
  1.  I +$G(NOTALL) S VAUTNALL=1
  1.  D DIVISION^VAUTOMA
  1.  I Y<0 K VAUTD
  1. ASKDIVQ Q $D(VAUTD)>0
  1.  ;
  1. EMGRES(DFN)     ;DG*5.3*677
  1.  ;This API returns the value of the Emergency Response
  1.  ;Indicator (file 2, field .181), or null if blank
  1.  ;
  1.  ;INPUT:
  1.  ;   DFN - pointer to the Patient File (#2)
  1.  ;
  1.  ;OUTPUT:
  1.  ;   Function value - returns value from E.R.I. field, or null if blank
  1.  ;
  1.  I 'DFN Q ""
  1.  ;
  1.  N RESULT
  1.  S RESULT=$P($G(^DPT(DFN,.18)),U)
  1.  Q RESULT