source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCDXUTL1.m@ 812

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

initial load of FOIAVistA 6/30/08 version
File size: 3.5 KB
Line 
1SCDXUTL1 ;ALB/JRP - GENERAL UTILITY ROUTINES;10-MAY-1996
2 ;;5.3;Scheduling;**44,60,132**;AUG 13, 1993
3 ;
4GETDTRNG(EARLIEST,LATEST,HELPBGN,HELPEND) ;Prompt user for a date range
5 ;
6 ;Input : EARLIEST - Earliest date allowed in FileMan format (Optional)
7 ; LATEST - Latest date allowed in FileMan format (Optional)
8 ; HELPBGN - Array containing help information for beginning
9 ; date (Full global reference) (Optional)
10 ; HELPEND - Array containing help information for ending
11 ; date (Full global reference) (Optional)
12 ;Output : Begin^End - Success
13 ; Begin - Beginning date
14 ; End - Ending date
15 ; -1 - User abort / timed out
16 ;Notes : HELPBGN & HELPEND arrays have same format as DIR("?",#) array
17 ;
18 ;Check input
19 S EARLIEST=$G(EARLIEST)
20 S LATEST=$G(LATEST)
21 S HELPBGN=$G(HELPBGN)
22 S HELPEND=$G(HELPEND)
23 ;Declare variables
24 N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,BEGIN,END
25 ;Get beginning date
26 S DIR(0)="DA^"_EARLIEST_":"_LATEST_":EPX"
27 S DIR("A")="Enter beginning date: "
28 I (HELPBGN'="") M DIR("?")=@HELPBGN
29 D ^DIR
30 S BEGIN=+Y
31 ;User abort / time out
32 Q:($D(DIRUT)) -1
33 ;Get ending date
34 K DIR
35 S DIR(0)="DA^"_BEGIN_":"_LATEST_":EPX"
36 S DIR("A")="Enter ending date: "
37 I (HELPEND'="") M DIR("?")=@HELPEND
38 D ^DIR
39 S END=+Y
40 ;User abort / time out
41 Q:($D(DIRUT)) -1
42 ;Done
43 Q BEGIN_"^"_END
44 ;
45REPEAT(CHAR,TIMES) ;Repeat a string
46 ;INPUT : CHAR - Character to repeat
47 ; TIMES - Number of times to repeat CHAR
48 ;OUTPUT : s - String of CHAR that is TIMES long
49 ; "" - Error (bad input)
50 ;
51 ;Check input
52 Q:($G(CHAR)="") ""
53 Q:((+$G(TIMES))=0) ""
54 ;Return string
55 Q $TR($J("",TIMES)," ",CHAR)
56 ;
57INSERT(INSTR,OUTSTR,COLUMN,LENGTH) ;Insert a string into another string
58 ;INPUT : INSTR - String to insert
59 ; OUTSTR - String to insert into
60 ; COLUMN - Where to begin insertion (defaults to end of OUTSTR)
61 ; LENGTH - Number of characters to clear from OUTSTR
62 ; (defaults to length of INSTR)
63 ;OUTPUT : s - INSTR will be placed into OUTSTR starting at COLUMN
64 ; using LENGTH characters
65 ; "" - Error (bad input)
66 ;
67 ;NOTE : This module is based on $$SETSTR^VALM1
68 ;
69 ;Check input
70 S INSTR=$G(INSTR)
71 Q:(INSTR="") $G(OUTSTR)
72 S OUTSTR=$G(OUTSTR)
73 S:('$D(COLUMN)) COLUMN=$L(OUTSTR)+1
74 S:('$D(LENGTH)) LENGTH=$L(INSTR)
75 ;Declare variables
76 N FRONT,END
77 S FRONT=$E((OUTSTR_$J("",COLUMN-1)),1,(COLUMN-1))
78 S END=$E(OUTSTR,(COLUMN+LENGTH),$L(OUTSTR))
79 ;Insert string
80 Q FRONT_$E((INSTR_$J("",LENGTH)),1,LENGTH)_END
81 ;
82DIAG(SDPOE,SCDXARRY) ;Get diagnoses from V POV file
83 ; Note: Returns Dx from children (if any)
84 ;
85 ; SDPOE - pointer to 409.68
86 ; SCDGARRY - output array
87 ;
88 N SCOPDX,SDCHILD,SDOE
89 D KIDS(SDPOE,"SDCHILD")
90 ;
91 ; -- get parent dxs
92 D GETDX^SDOE(+$G(SDPOE),SCDXARRY)
93 ;
94 ; -- get child dxs
95 S SDOE=0
96 F S SDOE=$O(SDCHILD(SDOE)) Q:'SDOE D
97 . D GETDX^SDOE(SDOE,SCDXARRY)
98 Q
99 ;
100PRIMPDX(SDPOE) ; return pointer to ICD9 for primary dx of parent encounter
101 ; Note: Includes
102 ; SDPOE - encounter (parent)
103 ; return:
104 ; if one: ptr to ICD DIAGNOSIS file (ICD9)^pointer to V POV file
105 ; if none: no prim dx
106 ; if two+: -1 (error)
107 ;
108 N SCDX,SCX,SCDX1,SDCHILD,SDOE
109 S SCDX1=0
110 D DIAG(.SDPOE,"SCDX")
111 S SCX=0
112 F S SCX=$O(SCDX(SCX)) Q:'SCX IF $P(SCDX(SCX),U,12)="P" S:SCDX1 SCDX1=-1 Q:SCDX1 S SCDX1=(+SCDX(SCX))_U_SCX
113 Q SCDX1
114 ;
115KIDS(SDOE,SCKIDS) ;return children of parent
116 ; Input - SDOE = ptr to 409.68
117 ; Output- @SCKIDS@(kid ptr to 409.68) array
118 N SCX
119 S SCX=0 F S SCX=$O(^SCE("APAR",SDOE,SCX)) Q:'SCX S @SCKIDS@(SCX)=""
120 Q
Note: See TracBrowser for help on using the repository browser.