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 Apr 09, 2024@21:29:06 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 ;
