source: qrda/C0Q/trunk/p/C0QUTIL.m

Last change on this file was 1501, checked in by Sam Habiel, 12 years ago

Latest routines; T11 copy

File size: 5.1 KB
Line 
1C0QUTIL ;JJOH/ZAG/GPL - Utilities for C0Q Package ; 7/31/12 7:42am
2 ;;1.0;C0Q;;May 21, 2012;Build 63
3 ;
4 ;2011 Licensed under the terms of the GNU General Public License
5 ;See attached copy of the License.
6 ;
7 ;This program is free software; you can redistribute it and/or modify
8 ;it under the terms of the GNU General Public License as published by
9 ;the Free Software Foundation; either version 2 of the License, or
10 ;(at your option) any later version.
11 ;
12 ;This program is distributed in the hope that it will be useful,
13 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;GNU General Public License for more details.
16 ;
17 ;You should have received a copy of the GNU General Public License along
18 ;with this program; if not, write to the Free Software Foundation, Inc.,
19 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
20 ;
21AGE(DFN) ; return current age in years and months
22 ;
23 Q:'$G(DFN) ;quit if no there is no patient
24 N DOB S DOB=$P(^DPT(+DFN,0),U,3) ;date of birth
25 N YRS
26 N DOD S DOD=+$G(^DPT(9,.35)) ;check for date of death
27 I 'DOD D
28 . N CDTE S CDTE=DT ;current date
29 . S YRS=$E(CDTE,1,3)-$E(DOB,1,3)-($E(CDTE,4,7)<$E(DOB,4,7))
30 E D
31 . S YRS=$E(DOD,1,3)-$E(DOB,1,3)-($E(DOD,4,7)<$E(DOB,4,7))
32 ;
33 ;Come back here and fix MONTHS and DAYS
34 ;N CM S CM=+$E(DT,4,5) ;current month
35 ;N CD S CD=+$E(DT,6,7) ;current day
36 ;N BM S BM=+$E(DOB,4,5) ;birth month
37 ;N BD S BD=+$E(DOB,6,7) ;birth day
38 ;
39 ;N DAYS S DAYS=""
40 ;
41 Q YRS ;_"y" gpl ..just want the number
42 ;
43 ;
44DTDIFF(ZD1,ZT1,ZD2,ZT2,SHOW) ; extrinsic which returns the number of minutes
45 ; between 2 dates. ZD1 and ZD2 are fileman dates
46 ; ZT1 AND ZT2 are valid times (military time) ie 20:10
47 ; IF SHOW=1 DEBUGGING INTERMEDIATE VALUES WILL BE DISPLAYED
48 I '$D(SHOW) S SHOW=0
49 N GT1,GT2,GDT1,GDT2
50 I ZT1[":" D ;
51 . S GT1=($P(ZT1,":",1)*3600)+($P(ZT1,":",2)*60) ; SECONDS
52 . S GT2=($P(ZT2,":",1)*3600)+($P(ZT2,":",2)*60) ; SECONDS
53 E D ;
54 . S GT1=($E(ZT1,1,2)*3600)+($E(ZT1,3,4)*60)
55 . S GT2=($E(ZT2,1,2)*3600)+($E(ZT2,3,4)*60)
56 ;W:SHOW !,"SECONDS: ",GT1," ",GT2
57 ;S %=GT1 D S^%DTC ; FILEMAN TIME
58 ;S GDT1=ZD1_% ; FILEMAN DATE AND TIME
59 ;S %=GT2 D S^%DTC ; FILEMAN TIME
60 ;S GDT2=ZD2_% ; FILEMAN DATE AND TIME
61 S GDT1=ZD1_"."_ZT1
62 S GDT2=ZD2_"."_ZT2
63 W:SHOW !,"FILEMAN: ",GDT1," ",GDT2
64 N ZH1,ZH2
65 S ZH1=$$FMTH^XLFDT(GDT1) ; $H FORMAT
66 S ZH2=$$FMTH^XLFDT(GDT2) ; $H FORMAT
67 W:SHOW !,"$H: ",ZH1," ",ZH2
68 N ZSECS,ZMIN
69 S ZSECS=$$HDIFF^XLFDT(ZH1,ZH2,2) ; DIFFERENCE IN $H
70 W:SHOW !,"DIFF: ",ZSECS
71 S ZMIN=ZSECS/60 ; DIFFERENCE IN MINUTES
72 W:SHOW !,"MIN: ",ZMIN
73 Q ZMIN
74 ;
75DT(X) ; -- Returns FM date for X
76 N Y,%DT S %DT="T",Y="" D:X'="" ^%DT
77 Q Y
78 ;
79ZWRITE(NAME) ; Replacement for ZWRITE ; Public Proc
80 ; Pass NAME by name as a closed reference. lvn and gvn are both supported.
81 ; : syntax is not supported (yet)
82 N L S L=$L(NAME) ; Name length
83 I $E(NAME,L-2,L)=",*)" S NAME=$E(NAME,1,L-3)_")" ; If last sub is *, remove it and close the ref
84 N ORIGLAST S ORIGLAST=$QS(NAME,$QL(NAME)) ; Get last subscript upon which we can't loop further
85 N ORIGQL S ORIGQL=$QL(NAME) ; Number of subscripts in the original name
86 I $D(@NAME)#2 W NAME,"=",$$FORMAT(@NAME),! ; Write base if it exists
87 ; $QUERY through the name.
88 ; Stop when we are out.
89 ; Stop when the last subscript of the original name isn't the same as
90 ; the last subscript of the Name.
91 F S NAME=$Q(@NAME) Q:NAME="" Q:$QS(NAME,ORIGQL)'=ORIGLAST W NAME,"=",$$FORMAT(@NAME),!
92 QUIT
93FORMAT(V) ; Add quotes, replace control characters if necessary; Public $$
94 ;If numeric, nothing to do.
95 ;If no encoding required, then return as quoted string.
96 ;Otherwise, return as an expression with $C()'s and strings.
97 I +V=V Q V ; If numeric, just return the value.
98 N QT S QT="""" ; Quote
99 I $F(V,QT) D ;chk if V contains any Quotes
100 . S P=0 ;position pointer into V
101 . F S P=$F(V,QT,P) Q:'P D ;find next "
102 . . S $E(V,P-1)=QT_QT ;double each "
103 . . S P=P+1 ;skip over new "
104 I $$CCC(V) D Q V ; If control character is present do this and quit
105 . S V=$$RCC(QT_V_QT) ; Replace control characters in "V"
106 . S:$E(V,1,3)="""""_" $E(V,1,3)="" ; Replace doubled up quotes at start
107 . S L=$L(V) S:$E(V,L-2,L)="_""""" $E(V,L-2,L)="" ; Replace doubled up quotes at end
108 Q QT_V_QT ; If no control charactrrs, quit with "V"
109 ;
110CCC(S) ;test if S Contains a Control Character or $C(255); Public $$
111 Q:S?.E1C.E 1
112 Q:$F(S,$C(255)) 1
113 Q 0
114RCC(NA) ;Replace control chars in NA with $C( ). Returns encoded string; Public $$
115 Q:'$$CCC(NA) NA ;No embedded ctrl chars
116 N OUT S OUT="" ;holds output name
117 N CC S CC=0 ;count ctrl chars in $C(
118 N C ;temp hold each char
119 F I=1:1:$L(NA) S C=$E(NA,I) D ;for each char C in NA
120 . I C'?1C,C'=C255 D S OUT=OUT_C Q ;not a ctrl char
121 . . I CC S OUT=OUT_")_""",CC=0 ;close up $C(... if one is open
122 . I CC D
123 . . I CC=256 S OUT=OUT_")_$C("_$A(C),CC=0 ;max args in one $C(
124 . . E S OUT=OUT_","_$A(C) ;add next ctrl char to $C(
125 . E S OUT=OUT_"""_$C("_$A(C)
126 . S CC=CC+1
127 . Q
128 Q OUT
129END ;end of C0QUTIL
Note: See TracBrowser for help on using the repository browser.