source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGUTL.m@ 1590

Last change on this file since 1590 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 5.4 KB
Line 
1DGUTL ;ALB/MRL - DG UTILITY FUNCTIONS ; 08 JAN 86
2 ;;5.3;Registration;**279,570,677**;Aug 13, 1993
3 ;
4RI ;Reimbursable Insurance
5 ; ** NOTE: This procedure appears to be obsolete, but code was modified
6 ; for IB/AR Encapsulation anyways.
7 S DGINS=$$INSUR^IBBAPI(DFN,"","A")
8 Q
9 ;
10TS ;Table of Contents SET
11 I '$D(^UTILITY($J,"DGTC",DGPAG)) S ^UTILITY($J,"DGTC",DGPAG,DGPAG1)="" Q
12TP ;Table of Contents PRINT
13 I '$D(^UTILITY($J,"DGTC")) Q
14 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
15 W ! K ^UTILITY($J,"DGTC"),I,I1,J,J1,DGTCH,X,Y Q
16TH ;Table of Contents HEADER
17 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
18C ;Cover Page
19 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)
20 S TT=$S($D(IOSL):IOSL-(TT*2+10)\2,1:66-(TT*2+10)\2) F I=1:1:TT W !
21 F I=0:0 S I=$O(DGCPG(I)) Q:'I W !!?$P(DGCPG(I),U,2),$P(DGCPG(I),U,1)
22 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
23 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
24 I $D(DGCPT) X "F I=1:1:$S($D(IOSL):(IOSL-5),1:61)-$Y W !" W DGCPT
25 W !! K TT,I,X,X1 Q
26H ;Convert $H to Readable Date/Time
27 D:'$D(DT) DT^DICRW S DGTIME=$P($H,",",2),DGTIME=DT+(DGTIME\3600/100)+(DGTIME\60#60/10000),DGDATE=DGTIME\1 Q
28DIV ;Determine Division
29 I $D(^DG(43,1,"GL")),$P(^("GL"),"^",2) S DGDIV="" Q
30 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)
31 Q
32DT 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
33EOM ;Required Variable: X - Date should be in internal FM date format
34 ;Returned Variable: Y - End of Month in internal FM date format
35 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
36 Q
37LO D:'$D(DT) DT^DICRW S:'$D(DTIME) DTIME=300 S U="^" Q
38 I '$D(^DG(43,1,0)) W !,"ADT parameters not set up",*7 G H^XUS
39 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
40 K USER Q
41 ;
42UPPER(X) ; -- convert to uppercase
43 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
44 ;
45LOWER(X) ;
46 N Y,C,Z,I
47 S Y=$E(X)_$TR($E(X,2,999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ@","abcdefghijklmnopqrstuvwxyz ")
48 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)
49 Q Y
50QUES(DFN,DGQCODE) ; EDIT REGISTRATION DATA FOR AMIE USE ONLY
51 ;
52 ; INPUT:
53 ; DFN
54 ; DGQCODE = Code for question(s) to be asked
55 ; OUTPUT:
56 ; DGERR = ERROR VARIABLE
57 ; DGCHANGE= 1 IF DATA MODIFIED 0 O/W
58 ;
59 N D,D0,DI,DIC,DGCODE,DGDR,DGNODE,DGQNODES,DGPC,DGPTND,DGRPS,DGQ,DGX,DQ,N,X,Y,%Y
60 S (DGERR,DGRPS,DGCHANGE)=0
61 G:'($G(DFN)&($G(DGQCODE)="ADD1")) QTE
62 S DGPC=2,DGCODE="ADD1"
63 S DGDR=104
64 S DGRPS=1
65 S DGQNODES=".11~.13"
66 F N=1:1 S DGNODE=$P(DGQNODES,"~",N) Q:DGNODE']"" S DGPTND(DGNODE)=$G(^DPT(DFN,DGNODE))
67 D ^DGRPE
68 F DGNODE=0:0 S DGNODE=$O(DGPTND(DGNODE)) Q:DGNODE']"" S:$G(^DPT(DFN,DGNODE))'=(DGPTND(DGNODE)) DGCHANGE=1
69QTE I 'DGRPS S DGERR=1
70QTQ Q
71 ;FORM FEED & STOPPING UTILITIES
72FIRST() ;First heading of report
73 ; RETURNS STOP; 0=GO,1=STOP
74 N STOP
75 D STOPCHK
76 D:$G(STOP) STOPPED
77 I '$G(STOP),$E($G(IOST),1,2)="C-" W @IOF
78 Q $G(STOP)
79 ;
80SUBSEQ() ;enter for further headings of report
81 ; RETURNS STOP; 0=GO,1=STOP
82 N STOP,DIR,X,Y
83 D STOPCHK
84 I $E($G(IOST),1,2)="C-" S DIR(0)="E" D ^DIR S:$D(DIRUT) STOP=1
85 D:$G(STOP) STOPPED
86 I '$G(STOP) W @IOF
87 Q $G(STOP)
88 ;
89STOPCHK I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,STOP)=1
90 Q
91STOPPED ;
92 W !?5,"------------- Report stopped at user's request ------------"
93 K ZTREQ
94 Q
95ENDREP I $E(IOST,1,2)'["C-" W:$Y&'$D(IONOFF) @IOF Q
96 Q
97 ;
98ASKDIV(NOTALL) ;Ask for division (one/many/all)
99 ; Input: NOTALL - Flag that prevents selection of all divisions
100 ; 1 = Don't allow selection of all divisions
101 ; 0 = Allow selection of all divisions (default)
102 ;Output: Integer indicating if selection was made
103 ; 0 = No divisions selected (user quit)
104 ; 1 = Divisions selected
105 ; VAUTD will be set as follows:
106 ; VAUTD = 1 if all divisions selected
107 ; VAUTD = 0 if individual divisions selected
108 ; VAUTD(DivPtr) = DivisionName for each division selected
109 ; Notes: VAUTD is KILLed in input
110 ;
111 N FIRSTDIV,MULTIDIV,Y,VAUTNALL
112 K VAUTD
113 S FIRSTDIV=+$O(^DG(40.80,0))
114 I '$D(^DG(40.8,FIRSTDIV,0)) D G ASKDIVQ
115 . W !
116 . W $C(7),"***WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP***"
117 . W !
118 S MULTIDIV=+$P($G(^DG(43,1,"GL")),"^",2)
119 I 'MULTIDIV S VAUTD=1 G ASKDIVQ
120 S (VAUTD,Y)=0
121 I +$G(NOTALL) S VAUTNALL=1
122 D DIVISION^VAUTOMA
123 I Y<0 K VAUTD
124ASKDIVQ Q $D(VAUTD)>0
125 ;
126EMGRES(DFN) ;DG*5.3*677
127 ;This API returns the value of the Emergency Response
128 ;Indicator (file 2, field .181), or null if blank
129 ;
130 ;INPUT:
131 ; DFN - pointer to the Patient File (#2)
132 ;
133 ;OUTPUT:
134 ; Function value - returns value from E.R.I. field, or null if blank
135 ;
136 I 'DFN Q ""
137 ;
138 N RESULT
139 S RESULT=$P($G(^DPT(DFN,.18)),U)
140 Q RESULT
Note: See TracBrowser for help on using the repository browser.