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

ORRHCU.m

Go to the documentation of this file.
  1. ORRHCU ; SLC/KCM - CPRS Query Tools - Utilities ; [8/6/03 1:27Pm]
  1. ;;3.0;ORDER ENTRY/RESULTS REPORTING;**153,174**;Dec 17, 1997
  1. ;
  1. NXT() ; Increment ILST
  1. S ILST=ILST+1
  1. Q ILST
  1. ;
  1. RNG2FM(RNG) ; convert a relative date range to Fileman dates
  1. N FMRNG
  1. I $E(RNG,1)="Y" D
  1. . N YR,TYP,QTR
  1. . S YR=$E(DT,1,3),TYP=$E(RNG,2) I (TYP="F"),(+$E(DT,4,5)>9) S YR=YR+1
  1. . S YR=YR+$E(RNG,3,999)
  1. . I (RNG["Q"),($P(RNG,"Q",2)="") S RNG=RNG_$$CURQTR($E(RNG,2)="F")
  1. . I $P(RNG,"Q",2)="" D Q
  1. . . I TYP="C" S FMRNG=YR_"0101:"_YR_"1231"
  1. . . I TYP="F" S FMRNG=(YR-1)_"1001:"_YR_"0930"
  1. . S QTR=+$P(RNG,"Q",2)
  1. . I TYP="F" S:QTR=1 YR=YR-1 S QTR=QTR-1 S:QTR=0 QTR=4
  1. . S FMRNG=YR_$P("0101^0401^0701^1001",U,QTR)_":"_YR
  1. . S FMRNG=FMRNG_$P("0331^0630^0930^1231",U,QTR)
  1. E D
  1. . N BDT,EDT,%DT,X,Y
  1. . S BDT=$P(RNG,":",1),EDT=$P(RNG,":",2)
  1. . I $L(BDT) S X=BDT D ^%DT S BDT=Y
  1. . I $L(EDT) S X=EDT D ^%DT S EDT=Y
  1. . I '$L(BDT) S BDT=0
  1. . I '$L(EDT) S EDT=9999999
  1. . S FMRNG=BDT_":"_EDT
  1. Q FMRNG
  1. CURQTR(ISFY) ; return the current fiscal or calendar quarter
  1. N QTR
  1. S QTR=$P(($E(DT,4,5)-1)/3,".")+1
  1. I ISFY S QTR=QTR+1 S:QTR=5 QTR=1
  1. Q QTR
  1. ID2EXT(LST,FN,IDLST) ; Return the external values for a set if IENs
  1. N I
  1. S I=0 F S I=$O(IDLST(I)) Q:'I D
  1. . I +IDLST(I)=0 S LST(I)=IDLST(I) Q
  1. . S LST(I)=IDLST(I)_U_$$GET1^DIQ(FN,IDLST(I),.01)
  1. Q
  1. BYREG(LST,NAM,MOD) ; List patients from registry
  1. N ILST,RC,ITR,PATID S ILST=0
  1. I $$PATITER^RORAPI01(.ITR,NAM,MOD)<0 Q
  1. F S RC=$$NEXTPAT^RORAPI01(.ITR) Q:RC'>0 D
  1. . S PATID=$P(RC,U)
  1. . S LST($$NXT)=PATID_U_$P(^DPT(PATID,0),U)
  1. Q
  1. REGLST(LST) ; List available local registries
  1. S LST(1)="VA HEPC^Local HepC Registry"
  1. Q
  1. REGNAM(VAL,ID) ; Return the full name of a registry
  1. S VAL="Unknown Registry"
  1. I ID="VA HEPC" S VAL="Local HepC Registry"
  1. Q
  1. NMVAL(NM,VAL) ; Set a name=value pair
  1. Q:NM="" Q:VAL=""
  1. S LST($$NXT)=NM_"="_VAL
  1. Q
  1. DFLDS(LST,TYP) ; List display fields
  1. N I,J,ILST,X0 S ILST=0
  1. S TYP=$$DFLDTRAN(TYP) ; consults, orders return same fields
  1. S I=0 F S I=$O(^ORD(102.24,I)) Q:'I D
  1. . S X0=^ORD(102.24,I,0)
  1. . Q:TYP'[$E(X0) ; 1st char of name corresponds to type
  1. . ; S LST($$NXT)=X0
  1. . D NMVAL("DisplayName",$P(X0,U,2)) ; must be first
  1. . D NMVAL("InternalName",$P(X0,U))
  1. . D NMVAL("HeaderName",$P(X0,U,3))
  1. . D NMVAL("SortType",$P(X0,U,4))
  1. . S J=0 F S J=$O(^ORD(102.24,I,1,J)) Q:'J D
  1. . . D NMVAL("SampleData",$G(^ORD(102.24,I,1,J,0)))
  1. Q
  1. COLTYP(LST,SRC) ; List the column types
  1. N I,IEN
  1. S I=0 F S I=$O(SRC(I)) Q:'I D
  1. . S IEN=$O(^ORD(102.24,"B",SRC(I),0))
  1. . I 'IEN S LST(I)=SRC(I)_"^0"
  1. . E S LST(I)=SRC(I)_U_$P($G(^ORD(102.24,IEN,0)),U,4)
  1. Q
  1. ;
  1. DFLDMAP(LST) ; Returns a mapping of constraint types to display field types
  1. N FLDLIST S FLDLIST=$$GETFLDLS
  1. N TRANSLST S TRANSLST=$$DFLDTRAN(FLDLIST)
  1. N I S I=0
  1. F S I=I+1 Q:I>$L(FLDLIST) D
  1. .S LST(I)=$E(FLDLIST,I)_"="_$E(TRANSLST,I)
  1. Q
  1. ;
  1. DFLDTRAN(FLD) ;Translates the constraint types to the display field types
  1. Q $TR(FLD,"C","O")
  1. ;
  1. GETFLDLS() ;Returns a list of defined display fields
  1. N LIST
  1. S LIST="PODVC"
  1. Q LIST
  1. ;