source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORRHCU.m@ 1765

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

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1ORRHCU ; SLC/KCM - CPRS Query Tools - Utilities ; [8/6/03 1:27Pm]
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**153,174**;Dec 17, 1997
3 ;
4NXT() ; Increment ILST
5 S ILST=ILST+1
6 Q ILST
7 ;
8RNG2FM(RNG) ; convert a relative date range to Fileman dates
9 N FMRNG
10 I $E(RNG,1)="Y" D
11 . N YR,TYP,QTR
12 . S YR=$E(DT,1,3),TYP=$E(RNG,2) I (TYP="F"),(+$E(DT,4,5)>9) S YR=YR+1
13 . S YR=YR+$E(RNG,3,999)
14 . I (RNG["Q"),($P(RNG,"Q",2)="") S RNG=RNG_$$CURQTR($E(RNG,2)="F")
15 . I $P(RNG,"Q",2)="" D Q
16 . . I TYP="C" S FMRNG=YR_"0101:"_YR_"1231"
17 . . I TYP="F" S FMRNG=(YR-1)_"1001:"_YR_"0930"
18 . S QTR=+$P(RNG,"Q",2)
19 . I TYP="F" S:QTR=1 YR=YR-1 S QTR=QTR-1 S:QTR=0 QTR=4
20 . S FMRNG=YR_$P("0101^0401^0701^1001",U,QTR)_":"_YR
21 . S FMRNG=FMRNG_$P("0331^0630^0930^1231",U,QTR)
22 E D
23 . N BDT,EDT,%DT,X,Y
24 . S BDT=$P(RNG,":",1),EDT=$P(RNG,":",2)
25 . I $L(BDT) S X=BDT D ^%DT S BDT=Y
26 . I $L(EDT) S X=EDT D ^%DT S EDT=Y
27 . I '$L(BDT) S BDT=0
28 . I '$L(EDT) S EDT=9999999
29 . S FMRNG=BDT_":"_EDT
30 Q FMRNG
31CURQTR(ISFY) ; return the current fiscal or calendar quarter
32 N QTR
33 S QTR=$P(($E(DT,4,5)-1)/3,".")+1
34 I ISFY S QTR=QTR+1 S:QTR=5 QTR=1
35 Q QTR
36ID2EXT(LST,FN,IDLST) ; Return the external values for a set if IENs
37 N I
38 S I=0 F S I=$O(IDLST(I)) Q:'I D
39 . I +IDLST(I)=0 S LST(I)=IDLST(I) Q
40 . S LST(I)=IDLST(I)_U_$$GET1^DIQ(FN,IDLST(I),.01)
41 Q
42BYREG(LST,NAM,MOD) ; List patients from registry
43 N ILST,RC,ITR,PATID S ILST=0
44 I $$PATITER^RORAPI01(.ITR,NAM,MOD)<0 Q
45 F S RC=$$NEXTPAT^RORAPI01(.ITR) Q:RC'>0 D
46 . S PATID=$P(RC,U)
47 . S LST($$NXT)=PATID_U_$P(^DPT(PATID,0),U)
48 Q
49REGLST(LST) ; List available local registries
50 S LST(1)="VA HEPC^Local HepC Registry"
51 Q
52REGNAM(VAL,ID) ; Return the full name of a registry
53 S VAL="Unknown Registry"
54 I ID="VA HEPC" S VAL="Local HepC Registry"
55 Q
56NMVAL(NM,VAL) ; Set a name=value pair
57 Q:NM="" Q:VAL=""
58 S LST($$NXT)=NM_"="_VAL
59 Q
60DFLDS(LST,TYP) ; List display fields
61 N I,J,ILST,X0 S ILST=0
62 S TYP=$$DFLDTRAN(TYP) ; consults, orders return same fields
63 S I=0 F S I=$O(^ORD(102.24,I)) Q:'I D
64 . S X0=^ORD(102.24,I,0)
65 . Q:TYP'[$E(X0) ; 1st char of name corresponds to type
66 . ; S LST($$NXT)=X0
67 . D NMVAL("DisplayName",$P(X0,U,2)) ; must be first
68 . D NMVAL("InternalName",$P(X0,U))
69 . D NMVAL("HeaderName",$P(X0,U,3))
70 . D NMVAL("SortType",$P(X0,U,4))
71 . S J=0 F S J=$O(^ORD(102.24,I,1,J)) Q:'J D
72 . . D NMVAL("SampleData",$G(^ORD(102.24,I,1,J,0)))
73 Q
74COLTYP(LST,SRC) ; List the column types
75 N I,IEN
76 S I=0 F S I=$O(SRC(I)) Q:'I D
77 . S IEN=$O(^ORD(102.24,"B",SRC(I),0))
78 . I 'IEN S LST(I)=SRC(I)_"^0"
79 . E S LST(I)=SRC(I)_U_$P($G(^ORD(102.24,IEN,0)),U,4)
80 Q
81 ;
82DFLDMAP(LST) ; Returns a mapping of constraint types to display field types
83 N FLDLIST S FLDLIST=$$GETFLDLS
84 N TRANSLST S TRANSLST=$$DFLDTRAN(FLDLIST)
85 N I S I=0
86 F S I=I+1 Q:I>$L(FLDLIST) D
87 .S LST(I)=$E(FLDLIST,I)_"="_$E(TRANSLST,I)
88 Q
89 ;
90DFLDTRAN(FLD) ;Translates the constraint types to the display field types
91 Q $TR(FLD,"C","O")
92 ;
93GETFLDLS() ;Returns a list of defined display fields
94 N LIST
95 S LIST="PODVC"
96 Q LIST
97 ;
Note: See TracBrowser for help on using the repository browser.