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