BQIDCAH1 ;PRXM/HC/ALA-Ad Hoc Search continued ; 01 Aug 2007 11:27 AM
;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
Q
;
ACHK(IEN) ;EP - Age check
NEW AGE,PAGE,TYP1,TYP2,OP1,OP2,AVAL1,AVAL2,PTYP,PVAL
;S AGE=$$GET1^DIQ(9000001,IEN_",",1102.99,"E")
S AGE=$$AGE^BQIAGE(IEN)
I AGE="" Q
;S PAGE=$$GET1^DIQ(9000001,IEN_",",1102.98,"E")
S PAGE=$$AGE^BQIAGE(IEN,,1)
;
S TYP1=$E(CRIT1,$L(CRIT1)-2,$L(CRIT1)),OP1=$E(CRIT1,1,1)
I TYP1'="YRS",TYP1'="MOS",TYP1'="DYS" S TYP1="YRS"
S AVAL1=$E(CRIT1,2,$L(CRIT1)-3)
I $E(OP1,1,1)="'" S OP1=$E(CRIT1,1,2),AVAL1=$E(CRIT1,3,$L(CRIT1)-3)
;
; If not inclusive or exclusive, then only one criteria
I $G(CRIT2)="" D
. ; If the search is in years, can just use the AGE value
. I TYP1="YRS" D Q
.. S AVAL1=$$STRIP^XLFSTR(CRIT1,TYP1)
.. I @(AGE_AVAL1) S @TGLOB@(IEN)="" Q
. ; If the search is not in years, must check the PRINTED AGE value
. ; for those ages in months and days
. S PVAL=$P(PAGE," ",1),PTYP=$P(PAGE," ",2)
. ;S AVAL1=$E(CRIT1,2,$L(CRIT1)-3)
. ; Check the operand for a 'not' and set operand and criteria value appropriately
. I $E(OP1,1,1)="'" S AVAL1=$E(CRIT1,3,$L(CRIT1)-3)
. ; If the criteria qualifier type is not equal to the printed age qualifier type
. I TYP1'=PTYP D Q
.. ; if the operand is less than or less than/equal, depending on the
.. ; criteria qualifier, certain print age qualifiers should be included or
.. ; excluded from the check
.. I OP1="<"!(OP1="'>") D
... I TYP1="MOS",PTYP="YRS" Q
... I TYP1="DYS",PTYP="YRS"!(PTYP="MOS") Q
... S @TGLOB@(IEN)=""
.. ; if the operand is greater than or greater than/equal, depending on the
.. ; criteria qualifier, certain print age qualifiers should be included or
.. ; excluded from the check
.. I OP1=">"!(OP1="'<") D
... I TYP1="MOS",PTYP="DYS" Q
... S @TGLOB@(IEN)=""
. ; if the criteria qualifier and the print age qualifer is the same, then
. ; simple arithmetic check can be done based on the operand
. I @(PVAL_OP1_AVAL1) S @TGLOB@(IEN)=""
;
; If inclusive or exclusive criteria is used
I $G(CRIT2)'="" D
. S TYP2=$E(CRIT2,$L(CRIT2)-2,$L(CRIT2)),OP2=$E(CRIT2,1,1)
. I TYP2'="YRS",TYP2'="MOS",TYP2'="DYS" S TYP2="YRS"
. S AVAL2=$E(CRIT2,2,$L(CRIT2)-3)
. I $E(OP2,1,1)="'" S OP2=$E(CRIT2,1,2),AVAL2=$E(CRIT2,3,$L(CRIT2)-3)
. ; If both criteria qualifiers are years, then AGE value can be checked
. I TYP1="YRS",TYP2="YRS" D Q
.. S AVAL1=$$STRIP^XLFSTR(CRIT1,TYP1)
.. S AVAL2=$$STRIP^XLFSTR(CRIT2,TYP2)
.. ; if operand contains a 'not' value, then it is inclusive and the value
.. ; must have both criteria as 'true'
.. I OP1["'",OP2["'" I @(AGE_AVAL1),@(AGE_AVAL2) S @TGLOB@(IEN)="" Q
.. ; if operand does not contain a 'not' value, then it is exclusive and the
.. ; value must have one criteria as 'true'
.. I OP1'["'",OP2'["'" D Q
... I @(AGE_AVAL1) S @TGLOB@(IEN)="" Q
... I @(AGE_AVAL2) S @TGLOB@(IEN)="" Q
. ;
. ; Can't compare non compatible qualifiers
. I TYP1="YRS",TYP2'="YRS" Q
. I TYP1="MOS",TYP2="DYS" Q
. ;
. S PVAL=$P(PAGE," ",1),PTYP=$P(PAGE," ",2)
. I PTYP=TYP1,PTYP=TYP2 D Q
.. S AVAL1=$$STRIP^XLFSTR(CRIT1,TYP1)
.. S AVAL2=$$STRIP^XLFSTR(CRIT2,TYP2)
.. I OP1["'",OP2["'" I @(PVAL_AVAL1),@(PVAL_AVAL2) S @TGLOB@(IEN)="" Q
.. I OP1'["'",OP2'["'" D Q
... I @(PVAL_AVAL1) S @TGLOB@(IEN)="" Q
... I @(PVAL_AVAL2) S @TGLOB@(IEN)="" Q
. ; Inclusive check
. I OP1="'<" D
.. I TYP1="MOS" D
... I PTYP="DYS" Q
... I PTYP="MOS",@(PVAL_OP1_AVAL1) D
.... I TYP2="YRS" S @TGLOB@(IEN)="" Q
... I PTYP=TYP2,@(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
.. I TYP1="DYS" D
... I PTYP="DYS",@(PVAL_OP1_AVAL1) D
.... I TYP2'="DYS" S @TGLOB@(IEN)="" Q
... I PTYP=TYP2,@(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
. ; Exclusive check
. I OP1="<" D
.. I TYP1="DYS" D
... I TYP2="DYS" D
.... I PTYP="DYS" D
..... I @(PVAL_OP1_AVAL1) S @TGLOB@(IEN)="" Q
..... I @(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
.... I PTYP="MOS"!(PTYP="YRS") S @TGLOB@(IEN)="" Q
... I TYP2="MOS" D
.... I PTYP="DYS",@(PVAL_OP1_AVAL1) S @TGLOB@(IEN)="" Q
.... I PTYP="MOS",@(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
.... I PTYP="YRS" S @TGLOB@(IEN)="" Q
... I TYP2="YRS" D
.... I PTYP="DYS",@(PVAL_OP1_AVAL1) S @TGLOB@(IEN)="" Q
.... I PTYP="MOS" Q
.... I PTYP="YRS",@(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
.. I TYP1="MOS" D
... I TYP2="DYS" Q
... I TYP2="MOS" D
.... I PTYP="DYS" S @TGLOB@(IEN)="" Q
.... I PTYP="MOS" D
..... I @(PVAL_OP1_AVAL1) S @TGLOB@(IEN)="" Q
..... I @(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
.... I PTYP="YRS" S @TGLOB@(IEN)="" Q
... I TYP2="YRS" D
.... I PTYP="DYS" S @TGLOB@(IEN)="" Q
.... I PTYP="MOS",@(PVAL_OP1_AVAL1) S @TGLOB@(IEN)="" Q
.... I PTYP="YRS",@(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
.. I TYP1="YRS" D
... I TYP2="DYS" Q
... I TYP2="MOS" Q
... I TYP2="YRS" D
.... I PTYP="DYS" S @TGLOB@(IEN)="" Q
.... I PTYP="MOS" S @TGLOB@(IEN)="" Q
.... I PTYP="YRS" D
..... I @(PVAL_OP1_AVAL1) S @TGLOB@(IEN)="" Q
..... I @(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
Q
;
DIAG(FGLOB,TGLOB,DIAG,MPARMS) ;EP - Diagnosis Category search
NEW DXPT,CT,DFN,STAT,AVL,RCIEN
I $G(TGLOB)="" Q
I $G(DIAG)]"" D DXC
I $D(MPARMS("DXCAT")) D
. I DXOP="!" D Q
.. S DIAG="" F S DIAG=$O(MPARMS("DXCAT",DIAG)) Q:DIAG="" D DXC
. I DXOP="&" D
.. S DIAG="",CT=0
.. F S DIAG=$O(MPARMS("DXCAT",DIAG)) Q:DIAG="" D
... S CT=CT+1,IEN=""
... F S IEN=$O(^BQIREG("B",DIAG,IEN)) Q:IEN="" D
.... S DFN=$P(^BQIREG(IEN,0),U,2)
.... S STAT=$P(^BQIREG(IEN,0),U,3)
.... ; Check for associated statuses
.... I '$D(APARMS),'$D(MAPARMS) S DXPT(DFN)=$G(DXPT(DFN))+1 Q
.... I $G(APARMS("DXCAT",DIAG,"DXSTAT"))'="" D Q
..... I STAT=$G(APARMS("DXCAT",DIAG,"DXSTAT")) S DXPT(DFN)=$G(DXPT(DFN))+1
.... S AVL=""
.... F S AVL=$O(MAPARMS("DXCAT",DIAG,"DXSTAT",AVL)) Q:AVL="" D
..... I STAT=AVL S DXPT(DFN)=$G(DXPT(DFN))+1
. ;
. S IEN="" F S IEN=$O(DXPT(IEN)) Q:IEN="" I DXPT(IEN)'=CT K DXPT(IEN)
. I $G(FGLOB)="" S IEN="" F S IEN=$O(DXPT(IEN)) Q:IEN="" S @TGLOB@(IEN)=""
. I $G(FGLOB)'="" S IEN="" F S IEN=$O(@FGLOB@(IEN)) Q:IEN="" I $D(DXPT(IEN))>0 S @TGLOB@(IEN)=""
K MAPARMS("DXCAT")
Q
;
DXC ;
I $G(FGLOB)'="" D
. S IEN=""
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D
.. I $D(^BQIREG("C",IEN,DIAG)) D
... S RCIEN=$O(^BQIREG("C",IEN,DIAG,""))
... S STAT=$P(^BQIREG(RCIEN,0),U,3)
... ;**Check for associated statuses
... I '$D(APARMS("DXCAT",DIAG)),'$D(MAPARMS("DXCAT",DIAG)) S @TGLOB@(IEN)="" Q
... ; I '$D(APARMS),'$D(MAPARMS) S @TGLOB@(IEN)="" Q
... I $G(APARMS("DXCAT",DIAG,"DXSTAT"))'="" D Q
.... I STAT=$G(APARMS("DXCAT",DIAG,"DXSTAT")) S @TGLOB@(IEN)=""
... S AVL=""
... F S AVL=$O(MAPARMS("DXCAT",DIAG,"DXSTAT",AVL)) Q:AVL="" D
.... I STAT=AVL S @TGLOB@(IEN)=""
;
NEW DFN,IEN
I $G(FGLOB)="" D
. S IEN=""
. F S IEN=$O(^BQIREG("B",DIAG,IEN)) Q:IEN="" D
.. S DFN=$P(^BQIREG(IEN,0),U,2)
.. S STAT=$P(^BQIREG(IEN,0),U,3)
.. ; Check for associated statuses
.. I '$D(APARMS),'$D(MAPARMS) S @TGLOB@(DFN)="" Q
.. I $G(APARMS("DXCAT",DIAG,"DXSTAT"))'="" D Q
... I STAT=$G(APARMS("DXCAT",DIAG,"DXSTAT")) S @TGLOB@(DFN)=""
.. I $D(MAPARMS("DXCAT",DIAG,"DXSTAT",STAT)) S @TGLOB@(DFN)=""
Q
;
;
BEN(FGLOB,TGLOB,BEN,MPARMS) ;EP - Beneficiary search
I $G(TGLOB)="" Q
I $G(BEN)]"" D BEN1
I $D(MPARMS("BEN")) S BEN="" F S BEN=$O(MPARMS("BEN",BEN)) Q:BEN="" D BEN1
Q
;
BEN1 ;
I $G(FGLOB)'="" D Q
. N IEN,BENPT
. S IEN=""
. F S IEN=$O(@FGLOB@(IEN)) Q:'IEN D
.. S BENPT=$$GET1^DIQ(9000001,IEN_",",1111,"I")
.. I BENPT=BEN S @TGLOB@(IEN)=""
;
N DFN
S DFN=""
F S DFN=$O(^AUPNPAT("AD",BEN,DFN)) Q:DFN="" S @TGLOB@(DFN)=""
Q
;
RANGE(VAL,ENT,RTYP) ; EP - Load relative from and through dates when RANGE, LRANGE, MRANGE
; parameter or filter has been selected.
; Input:
; VAL - Range value - e.g. last week
; ENT - Entry in file 90506
; RTYP - Relative timeframe variable name
;
Q:$G(VAL)=""
Q:$G(ENT)=""
N RNGIEN,CHOICE
S RNGIEN=$O(^BQI(90506,ENT,3,"B",RTYP,""))
I RNGIEN D Q
. S CHOICE=$O(^BQI(90506,ENT,3,RNGIEN,3,"B",VAL,""))
. I CHOICE D Q
.. N DA,IENS,EXEC
.. S DA=CHOICE,DA(1)=RNGIEN,DA(2)=ENT S IENS=$$IENS^DILF(.DA)
.. S EXEC=$$GET1^DIQ(90506.33,IENS,.02,"I")
.. Q:EXEC=""
.. I EXEC["RFROM="!(EXEC["RTHRU=") D Q
... S RFROM=$$DATE^BQIUL1($P($P(EXEC,"RFROM=",2),"~"))
... S RTHRU=$$DATE^BQIUL1($P($P(EXEC,"RTHRU=",2),"~"))
.. X EXEC
. S TN=""
. F S TN=$O(^BQI(90506.9,"B",VAL,TN)) Q:TN="" D
.. I '$D(^BQI(90506.9,TN,1,"B",RTYP)) Q
.. I $P(^BQI(90506.9,TN,0),U,4)'="" D Q
... S RFROM=$$DATE^BQIUL1($P(^BQI(90506.9,TN,0),U,3))
... S RTHRU=$$DATE^BQIUL1($P(^BQI(90506.9,TN,0),U,4))
.. S EXEC=$P(^BQI(90506.9,TN,0),U,5) I EXEC="" Q
.. X EXEC
;
S TN=""
F S TN=$O(^BQI(90506.9,"B",VAL,TN)) Q:TN="" D
. I '$D(^BQI(90506.9,TN,1,"B",RTYP)) Q
. S EXEC=$P(^BQI(90506.9,TN,0),U,5)
. I EXEC'="" X EXEC
. I ENT="IPC" Q
. I $P(^BQI(90506.9,TN,0),U,4)'="" D
.. S RFROM=$$DATE^BQIUL1($P(^BQI(90506.9,TN,0),U,3))
.. S RTHRU=$$DATE^BQIUL1($P(^BQI(90506.9,TN,0),U,4))
Q
;
CUR(RTY) ;EP Range for a week
; RTY = 'L' is Last, 'T' is This, and 'N' is Next
NEW CDOW
S CDOW=$$DOW^XLFDT(DT,1)
S RFROM=$$FMADD^XLFDT(DT,(0-CDOW))
S RTHRU=$$FMADD^XLFDT(DT,(6-CDOW))
I RTY="T" Q
I RTY="L" D
. S RTHRU=$$FMADD^XLFDT(RFROM,-1)
. S RFROM=$$FMADD^XLFDT(RTHRU,-6)
I RTY="N" D
. S RFROM=$$FMADD^XLFDT(RTHRU,1)
. S RTHRU=$$FMADD^XLFDT(RFROM,6)
Q
;
MON(RTY) ;EP Range for a month
NEW BQMON,CYR,PYR,NYR,BQDTE,EDAY
; RTY = 'L' is Last, 'T' is This, and 'N' is Next
S BQMON=$E(DT,4,5),CYR=$E(DT,1,3),PYR=CYR-1,NYR=CYR+1
S BQDTE=$P($T(MQ+BQMON),";;",2)
S BQMON=$P(BQDTE,U,1)
I $L(BQMON)=1 S BQMON="0"_BQMON
I RTY="N" D
. S RFROM=@($P(BQDTE,U,4))_$P(BQDTE,U,3)_"01"
. S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
. S RTHRU=@($P(BQDTE,U,4))_$P(BQDTE,U,3)_$P(EDAY,U,+$P(BQDTE,U,3))
I RTY="L" D
. S RFROM=@($P(BQDTE,U,6))_$P(BQDTE,U,5)_"01"
. S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
. S RTHRU=@($P(BQDTE,U,6))_$P(BQDTE,U,5)_$P(EDAY,U,+$P(BQDTE,U,5))
I RTY="T" D
. S RFROM=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_"01"
. S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
. S RTHRU=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_$P(EDAY,U,+$P(BQDTE,U,1))
Q
;
IMON ;EP
NEW CMON,CT,NUM
S CMON=$O(^BQIPROV("AD",""),-1),CT=1
S RTHRU=CMON
S NUM=$P(VAL,"Last ",2),NUM=$P(NUM," Months",1)
S FMON=CMON F N=CT+1:1:NUM S FMON=$O(^BQIPROV("AD",FMON),-1) Q:FMON="" S RFROM=FMON
Q
;
IWEEK ;EP
NEW CT,NUM,CWK,FWK
S CWK=$O(^BQIPROV("AE",""),-1),CT=1
I CWK="" S CWK=$O(^BQITEAM("AC",""),-1)
S RTHRU=CWK
S NUM=$P(VAL,"Last ",2),NUM=$P(NUM," Weeks",1)
I $D(^BQIPROV("AE")) S FWK=CWK F N=CT+1:1:NUM S FWK=$O(^BQIPROV("AE",FWK),-1) Q:FWK="" S RFROM=FWK Q
I $D(^BQITEAM("AC")) S FWK=CWK F N=CT+1:1:NUM S FWK=$O(^BQITEAM("AC",FWK),-1) Q:FWK="" S RFROM=FWK
Q
;
YR(RTY) ;EP Range for a year
NEW CYR,PYR,NYR
S CYR=$E(DT,1,3),PYR=CYR-1,NYR=CYR+1
I RTY="L" S RFROM=PYR_"0101",RTHRU=PYR_"1231"
I RTY="T" S RFROM=CYR_"0101",RTHRU=CYR_"1231"
I RTY="N" S RFROM=NYR_"0101",RTHRU=NYR_"1231"
I ENT="IPC" S RFROM=$E(RFROM,1,5)_"00",RTHRU=$E(RTHRU,1,5)_"00"
Q
;
GQTR(NUM) ;EP Range for a GPRA quarter
NEW CYR,PYR
S CYR=$E(DT,1,3),PYR=CYR-1
I NUM=1 S RFROM=PYR_"0701",RTHRU=PYR_"0930"
I NUM=2 S RFROM=PYR_"1001",RTHRU=PYR_"1231"
I NUM=3 S RFROM=CYR_"0101",RTHRU=CYR_"0331"
I NUM=4 S RFROM=CYR_"0401",RTHRU=CYR_"0630"
Q
;
CQTR(NUM) ;EP Range for a Calendar quarter
NEW CYR,PYR,NYR
S CYR=$E(DT,1,3)
I NUM=1 S RFROM=CYR_"0101",RTHRU=CYR_"0331"
I NUM=2 S RFROM=CYR_"0401",RTHRU=CYR_"0630"
I NUM=3 S RFROM=CYR_"0701",RTHRU=CYR_"0930"
I NUM=4 S RFROM=CYR_"1001",RTHRU=CYR_"1231"
Q
;
FQTR(NUM) ;EP Range for a Fiscal quarter
NEW CYR,PYR
S CYR=$E(DT,1,3),PYR=CYR-1
I NUM=1 S RFROM=PYR_"1001",RTHRU=PYR_"1231"
I NUM=2 S RFROM=CYR_"0101",RTHRU=CYR_"0331"
I NUM=3 S RFROM=CYR_"0401",RTHRU=CYR_"0630"
I NUM=4 S RFROM=CYR_"0701",RTHRU=CYR_"0930"
Q
;
MQ ;
;;01^CYR^02^CYR^12^PYR
;;02^CYR^03^CYR^01^CYR
;;03^CYR^04^CYR^02^CYR
;;04^CYR^05^CYR^03^CYR
;;05^CYR^06^CYR^04^CYR
;;06^CYR^07^CYR^05^CYR
;;07^CYR^08^CYR^06^CYR
;;08^CYR^09^CYR^07^CYR
;;09^CYR^10^CYR^08^CYR
;;10^CYR^11^CYR^09^CYR
;;11^CYR^12^CYR^10^CYR
;;12^CYR^01^NYR^11^CYR
BQIDCAH1 ;PRXM/HC/ALA-Ad Hoc Search continued ; 01 Aug 2007 11:27 AM
+1 ;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
+2 QUIT
+3 ;
ACHK(IEN) ;EP - Age check
+1 NEW AGE,PAGE,TYP1,TYP2,OP1,OP2,AVAL1,AVAL2,PTYP,PVAL
+2 ;S AGE=$$GET1^DIQ(9000001,IEN_",",1102.99,"E")
+3 SET AGE=$$AGE^BQIAGE(IEN)
+4 IF AGE=""
QUIT
+5 ;S PAGE=$$GET1^DIQ(9000001,IEN_",",1102.98,"E")
+6 SET PAGE=$$AGE^BQIAGE(IEN,,1)
+7 ;
+8 SET TYP1=$EXTRACT(CRIT1,$LENGTH(CRIT1)-2,$LENGTH(CRIT1))
SET OP1=$EXTRACT(CRIT1,1,1)
+9 IF TYP1'="YRS"
IF TYP1'="MOS"
IF TYP1'="DYS"
SET TYP1="YRS"
+10 SET AVAL1=$EXTRACT(CRIT1,2,$LENGTH(CRIT1)-3)
+11 IF $EXTRACT(OP1,1,1)="'"
SET OP1=$EXTRACT(CRIT1,1,2)
SET AVAL1=$EXTRACT(CRIT1,3,$LENGTH(CRIT1)-3)
+12 ;
+13 ; If not inclusive or exclusive, then only one criteria
+14 IF $GET(CRIT2)=""
Begin DoDot:1
+15 ; If the search is in years, can just use the AGE value
+16 IF TYP1="YRS"
Begin DoDot:2
+17 SET AVAL1=$$STRIP^XLFSTR(CRIT1,TYP1)
+18 IF @(AGE_AVAL1)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:2
QUIT
+19 ; If the search is not in years, must check the PRINTED AGE value
+20 ; for those ages in months and days
+21 SET PVAL=$PIECE(PAGE," ",1)
SET PTYP=$PIECE(PAGE," ",2)
+22 ;S AVAL1=$E(CRIT1,2,$L(CRIT1)-3)
+23 ; Check the operand for a 'not' and set operand and criteria value appropriately
+24 IF $EXTRACT(OP1,1,1)="'"
SET AVAL1=$EXTRACT(CRIT1,3,$LENGTH(CRIT1)-3)
+25 ; If the criteria qualifier type is not equal to the printed age qualifier type
+26 IF TYP1'=PTYP
Begin DoDot:2
+27 ; if the operand is less than or less than/equal, depending on the
+28 ; criteria qualifier, certain print age qualifiers should be included or
+29 ; excluded from the check
+30 IF OP1="<"!(OP1="'>")
Begin DoDot:3
+31 IF TYP1="MOS"
IF PTYP="YRS"
QUIT
+32 IF TYP1="DYS"
IF PTYP="YRS"!(PTYP="MOS")
QUIT
+33 SET @TGLOB@(IEN)=""
End DoDot:3
+34 ; if the operand is greater than or greater than/equal, depending on the
+35 ; criteria qualifier, certain print age qualifiers should be included or
+36 ; excluded from the check
+37 IF OP1=">"!(OP1="'<")
Begin DoDot:3
+38 IF TYP1="MOS"
IF PTYP="DYS"
QUIT
+39 SET @TGLOB@(IEN)=""
End DoDot:3
End DoDot:2
QUIT
+40 ; if the criteria qualifier and the print age qualifer is the same, then
+41 ; simple arithmetic check can be done based on the operand
+42 IF @(PVAL_OP1_AVAL1)
SET @TGLOB@(IEN)=""
End DoDot:1
+43 ;
+44 ; If inclusive or exclusive criteria is used
+45 IF $GET(CRIT2)'=""
Begin DoDot:1
+46 SET TYP2=$EXTRACT(CRIT2,$LENGTH(CRIT2)-2,$LENGTH(CRIT2))
SET OP2=$EXTRACT(CRIT2,1,1)
+47 IF TYP2'="YRS"
IF TYP2'="MOS"
IF TYP2'="DYS"
SET TYP2="YRS"
+48 SET AVAL2=$EXTRACT(CRIT2,2,$LENGTH(CRIT2)-3)
+49 IF $EXTRACT(OP2,1,1)="'"
SET OP2=$EXTRACT(CRIT2,1,2)
SET AVAL2=$EXTRACT(CRIT2,3,$LENGTH(CRIT2)-3)
+50 ; If both criteria qualifiers are years, then AGE value can be checked
+51 IF TYP1="YRS"
IF TYP2="YRS"
Begin DoDot:2
+52 SET AVAL1=$$STRIP^XLFSTR(CRIT1,TYP1)
+53 SET AVAL2=$$STRIP^XLFSTR(CRIT2,TYP2)
+54 ; if operand contains a 'not' value, then it is inclusive and the value
+55 ; must have both criteria as 'true'
+56 IF OP1["'"
IF OP2["'"
IF @(AGE_AVAL1)
IF @(AGE_AVAL2)
SET @TGLOB@(IEN)=""
QUIT
+57 ; if operand does not contain a 'not' value, then it is exclusive and the
+58 ; value must have one criteria as 'true'
+59 IF OP1'["'"
IF OP2'["'"
Begin DoDot:3
+60 IF @(AGE_AVAL1)
SET @TGLOB@(IEN)=""
QUIT
+61 IF @(AGE_AVAL2)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:3
QUIT
End DoDot:2
QUIT
+62 ;
+63 ; Can't compare non compatible qualifiers
+64 IF TYP1="YRS"
IF TYP2'="YRS"
QUIT
+65 IF TYP1="MOS"
IF TYP2="DYS"
QUIT
+66 ;
+67 SET PVAL=$PIECE(PAGE," ",1)
SET PTYP=$PIECE(PAGE," ",2)
+68 IF PTYP=TYP1
IF PTYP=TYP2
Begin DoDot:2
+69 SET AVAL1=$$STRIP^XLFSTR(CRIT1,TYP1)
+70 SET AVAL2=$$STRIP^XLFSTR(CRIT2,TYP2)
+71 IF OP1["'"
IF OP2["'"
IF @(PVAL_AVAL1)
IF @(PVAL_AVAL2)
SET @TGLOB@(IEN)=""
QUIT
+72 IF OP1'["'"
IF OP2'["'"
Begin DoDot:3
+73 IF @(PVAL_AVAL1)
SET @TGLOB@(IEN)=""
QUIT
+74 IF @(PVAL_AVAL2)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:3
QUIT
End DoDot:2
QUIT
+75 ; Inclusive check
+76 IF OP1="'<"
Begin DoDot:2
+77 IF TYP1="MOS"
Begin DoDot:3
+78 IF PTYP="DYS"
QUIT
+79 IF PTYP="MOS"
IF @(PVAL_OP1_AVAL1)
Begin DoDot:4
+80 IF TYP2="YRS"
SET @TGLOB@(IEN)=""
QUIT
End DoDot:4
+81 IF PTYP=TYP2
IF @(PVAL_OP2_AVAL2)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:3
+82 IF TYP1="DYS"
Begin DoDot:3
+83 IF PTYP="DYS"
IF @(PVAL_OP1_AVAL1)
Begin DoDot:4
+84 IF TYP2'="DYS"
SET @TGLOB@(IEN)=""
QUIT
End DoDot:4
+85 IF PTYP=TYP2
IF @(PVAL_OP2_AVAL2)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:3
End DoDot:2
+86 ; Exclusive check
+87 IF OP1="<"
Begin DoDot:2
+88 IF TYP1="DYS"
Begin DoDot:3
+89 IF TYP2="DYS"
Begin DoDot:4
+90 IF PTYP="DYS"
Begin DoDot:5
+91 IF @(PVAL_OP1_AVAL1)
SET @TGLOB@(IEN)=""
QUIT
+92 IF @(PVAL_OP2_AVAL2)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:5
+93 IF PTYP="MOS"!(PTYP="YRS")
SET @TGLOB@(IEN)=""
QUIT
End DoDot:4
+94 IF TYP2="MOS"
Begin DoDot:4
+95 IF PTYP="DYS"
IF @(PVAL_OP1_AVAL1)
SET @TGLOB@(IEN)=""
QUIT
+96 IF PTYP="MOS"
IF @(PVAL_OP2_AVAL2)
SET @TGLOB@(IEN)=""
QUIT
+97 IF PTYP="YRS"
SET @TGLOB@(IEN)=""
QUIT
End DoDot:4
+98 IF TYP2="YRS"
Begin DoDot:4
+99 IF PTYP="DYS"
IF @(PVAL_OP1_AVAL1)
SET @TGLOB@(IEN)=""
QUIT
+100 IF PTYP="MOS"
QUIT
+101 IF PTYP="YRS"
IF @(PVAL_OP2_AVAL2)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:4
End DoDot:3
+102 IF TYP1="MOS"
Begin DoDot:3
+103 IF TYP2="DYS"
QUIT
+104 IF TYP2="MOS"
Begin DoDot:4
+105 IF PTYP="DYS"
SET @TGLOB@(IEN)=""
QUIT
+106 IF PTYP="MOS"
Begin DoDot:5
+107 IF @(PVAL_OP1_AVAL1)
SET @TGLOB@(IEN)=""
QUIT
+108 IF @(PVAL_OP2_AVAL2)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:5
+109 IF PTYP="YRS"
SET @TGLOB@(IEN)=""
QUIT
End DoDot:4
+110 IF TYP2="YRS"
Begin DoDot:4
+111 IF PTYP="DYS"
SET @TGLOB@(IEN)=""
QUIT
+112 IF PTYP="MOS"
IF @(PVAL_OP1_AVAL1)
SET @TGLOB@(IEN)=""
QUIT
+113 IF PTYP="YRS"
IF @(PVAL_OP2_AVAL2)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:4
End DoDot:3
+114 IF TYP1="YRS"
Begin DoDot:3
+115 IF TYP2="DYS"
QUIT
+116 IF TYP2="MOS"
QUIT
+117 IF TYP2="YRS"
Begin DoDot:4
+118 IF PTYP="DYS"
SET @TGLOB@(IEN)=""
QUIT
+119 IF PTYP="MOS"
SET @TGLOB@(IEN)=""
QUIT
+120 IF PTYP="YRS"
Begin DoDot:5
+121 IF @(PVAL_OP1_AVAL1)
SET @TGLOB@(IEN)=""
QUIT
+122 IF @(PVAL_OP2_AVAL2)
SET @TGLOB@(IEN)=""
QUIT
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+123 QUIT
+124 ;
DIAG(FGLOB,TGLOB,DIAG,MPARMS) ;EP - Diagnosis Category search
+1 NEW DXPT,CT,DFN,STAT,AVL,RCIEN
+2 IF $GET(TGLOB)=""
QUIT
+3 IF $GET(DIAG)]""
DO DXC
+4 IF $DATA(MPARMS("DXCAT"))
Begin DoDot:1
+5 IF DXOP="!"
Begin DoDot:2
+6 SET DIAG=""
FOR
SET DIAG=$ORDER(MPARMS("DXCAT",DIAG))
IF DIAG=""
QUIT
DO DXC
End DoDot:2
QUIT
+7 IF DXOP="&"
Begin DoDot:2
+8 SET DIAG=""
SET CT=0
+9 FOR
SET DIAG=$ORDER(MPARMS("DXCAT",DIAG))
IF DIAG=""
QUIT
Begin DoDot:3
+10 SET CT=CT+1
SET IEN=""
+11 FOR
SET IEN=$ORDER(^BQIREG("B",DIAG,IEN))
IF IEN=""
QUIT
Begin DoDot:4
+12 SET DFN=$PIECE(^BQIREG(IEN,0),U,2)
+13 SET STAT=$PIECE(^BQIREG(IEN,0),U,3)
+14 ; Check for associated statuses
+15 IF '$DATA(APARMS)
IF '$DATA(MAPARMS)
SET DXPT(DFN)=$GET(DXPT(DFN))+1
QUIT
+16 IF $GET(APARMS("DXCAT",DIAG,"DXSTAT"))'=""
Begin DoDot:5
+17 IF STAT=$GET(APARMS("DXCAT",DIAG,"DXSTAT"))
SET DXPT(DFN)=$GET(DXPT(DFN))+1
End DoDot:5
QUIT
+18 SET AVL=""
+19 FOR
SET AVL=$ORDER(MAPARMS("DXCAT",DIAG,"DXSTAT",AVL))
IF AVL=""
QUIT
Begin DoDot:5
+20 IF STAT=AVL
SET DXPT(DFN)=$GET(DXPT(DFN))+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+21 ;
+22 SET IEN=""
FOR
SET IEN=$ORDER(DXPT(IEN))
IF IEN=""
QUIT
IF DXPT(IEN)'=CT
KILL DXPT(IEN)
+23 IF $GET(FGLOB)=""
SET IEN=""
FOR
SET IEN=$ORDER(DXPT(IEN))
IF IEN=""
QUIT
SET @TGLOB@(IEN)=""
+24 IF $GET(FGLOB)'=""
SET IEN=""
FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF IEN=""
QUIT
IF $DATA(DXPT(IEN))>0
SET @TGLOB@(IEN)=""
End DoDot:1
+25 KILL MAPARMS("DXCAT")
+26 QUIT
+27 ;
DXC ;
+1 IF $GET(FGLOB)'=""
Begin DoDot:1
+2 SET IEN=""
+3 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
Begin DoDot:2
+4 IF $DATA(^BQIREG("C",IEN,DIAG))
Begin DoDot:3
+5 SET RCIEN=$ORDER(^BQIREG("C",IEN,DIAG,""))
+6 SET STAT=$PIECE(^BQIREG(RCIEN,0),U,3)
+7 ;**Check for associated statuses
+8 IF '$DATA(APARMS("DXCAT",DIAG))
IF '$DATA(MAPARMS("DXCAT",DIAG))
SET @TGLOB@(IEN)=""
QUIT
+9 ; I '$D(APARMS),'$D(MAPARMS) S @TGLOB@(IEN)="" Q
+10 IF $GET(APARMS("DXCAT",DIAG,"DXSTAT"))'=""
Begin DoDot:4
+11 IF STAT=$GET(APARMS("DXCAT",DIAG,"DXSTAT"))
SET @TGLOB@(IEN)=""
End DoDot:4
QUIT
+12 SET AVL=""
+13 FOR
SET AVL=$ORDER(MAPARMS("DXCAT",DIAG,"DXSTAT",AVL))
IF AVL=""
QUIT
Begin DoDot:4
+14 IF STAT=AVL
SET @TGLOB@(IEN)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;
+16 NEW DFN,IEN
+17 IF $GET(FGLOB)=""
Begin DoDot:1
+18 SET IEN=""
+19 FOR
SET IEN=$ORDER(^BQIREG("B",DIAG,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+20 SET DFN=$PIECE(^BQIREG(IEN,0),U,2)
+21 SET STAT=$PIECE(^BQIREG(IEN,0),U,3)
+22 ; Check for associated statuses
+23 IF '$DATA(APARMS)
IF '$DATA(MAPARMS)
SET @TGLOB@(DFN)=""
QUIT
+24 IF $GET(APARMS("DXCAT",DIAG,"DXSTAT"))'=""
Begin DoDot:3
+25 IF STAT=$GET(APARMS("DXCAT",DIAG,"DXSTAT"))
SET @TGLOB@(DFN)=""
End DoDot:3
QUIT
+26 IF $DATA(MAPARMS("DXCAT",DIAG,"DXSTAT",STAT))
SET @TGLOB@(DFN)=""
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
+29 ;
BEN(FGLOB,TGLOB,BEN,MPARMS) ;EP - Beneficiary search
+1 IF $GET(TGLOB)=""
QUIT
+2 IF $GET(BEN)]""
DO BEN1
+3 IF $DATA(MPARMS("BEN"))
SET BEN=""
FOR
SET BEN=$ORDER(MPARMS("BEN",BEN))
IF BEN=""
QUIT
DO BEN1
+4 QUIT
+5 ;
BEN1 ;
+1 IF $GET(FGLOB)'=""
Begin DoDot:1
+2 NEW IEN,BENPT
+3 SET IEN=""
+4 FOR
SET IEN=$ORDER(@FGLOB@(IEN))
IF 'IEN
QUIT
Begin DoDot:2
+5 SET BENPT=$$GET1^DIQ(9000001,IEN_",",1111,"I")
+6 IF BENPT=BEN
SET @TGLOB@(IEN)=""
End DoDot:2
End DoDot:1
QUIT
+7 ;
+8 NEW DFN
+9 SET DFN=""
+10 FOR
SET DFN=$ORDER(^AUPNPAT("AD",BEN,DFN))
IF DFN=""
QUIT
SET @TGLOB@(DFN)=""
+11 QUIT
+12 ;
RANGE(VAL,ENT,RTYP) ; EP - Load relative from and through dates when RANGE, LRANGE, MRANGE
+1 ; parameter or filter has been selected.
+2 ; Input:
+3 ; VAL - Range value - e.g. last week
+4 ; ENT - Entry in file 90506
+5 ; RTYP - Relative timeframe variable name
+6 ;
+7 IF $GET(VAL)=""
QUIT
+8 IF $GET(ENT)=""
QUIT
+9 NEW RNGIEN,CHOICE
+10 SET RNGIEN=$ORDER(^BQI(90506,ENT,3,"B",RTYP,""))
+11 IF RNGIEN
Begin DoDot:1
+12 SET CHOICE=$ORDER(^BQI(90506,ENT,3,RNGIEN,3,"B",VAL,""))
+13 IF CHOICE
Begin DoDot:2
+14 NEW DA,IENS,EXEC
+15 SET DA=CHOICE
SET DA(1)=RNGIEN
SET DA(2)=ENT
SET IENS=$$IENS^DILF(.DA)
+16 SET EXEC=$$GET1^DIQ(90506.33,IENS,.02,"I")
+17 IF EXEC=""
QUIT
+18 IF EXEC["RFROM="!(EXEC["RTHRU=")
Begin DoDot:3
+19 SET RFROM=$$DATE^BQIUL1($PIECE($PIECE(EXEC,"RFROM=",2),"~"))
+20 SET RTHRU=$$DATE^BQIUL1($PIECE($PIECE(EXEC,"RTHRU=",2),"~"))
End DoDot:3
QUIT
+21 XECUTE EXEC
End DoDot:2
QUIT
+22 SET TN=""
+23 FOR
SET TN=$ORDER(^BQI(90506.9,"B",VAL,TN))
IF TN=""
QUIT
Begin DoDot:2
+24 IF '$DATA(^BQI(90506.9,TN,1,"B",RTYP))
QUIT
+25 IF $PIECE(^BQI(90506.9,TN,0),U,4)'=""
Begin DoDot:3
+26 SET RFROM=$$DATE^BQIUL1($PIECE(^BQI(90506.9,TN,0),U,3))
+27 SET RTHRU=$$DATE^BQIUL1($PIECE(^BQI(90506.9,TN,0),U,4))
End DoDot:3
QUIT
+28 SET EXEC=$PIECE(^BQI(90506.9,TN,0),U,5)
IF EXEC=""
QUIT
+29 XECUTE EXEC
End DoDot:2
End DoDot:1
QUIT
+30 ;
+31 SET TN=""
+32 FOR
SET TN=$ORDER(^BQI(90506.9,"B",VAL,TN))
IF TN=""
QUIT
Begin DoDot:1
+33 IF '$DATA(^BQI(90506.9,TN,1,"B",RTYP))
QUIT
+34 SET EXEC=$PIECE(^BQI(90506.9,TN,0),U,5)
+35 IF EXEC'=""
XECUTE EXEC
+36 IF ENT="IPC"
QUIT
+37 IF $PIECE(^BQI(90506.9,TN,0),U,4)'=""
Begin DoDot:2
+38 SET RFROM=$$DATE^BQIUL1($PIECE(^BQI(90506.9,TN,0),U,3))
+39 SET RTHRU=$$DATE^BQIUL1($PIECE(^BQI(90506.9,TN,0),U,4))
End DoDot:2
End DoDot:1
+40 QUIT
+41 ;
CUR(RTY) ;EP Range for a week
+1 ; RTY = 'L' is Last, 'T' is This, and 'N' is Next
+2 NEW CDOW
+3 SET CDOW=$$DOW^XLFDT(DT,1)
+4 SET RFROM=$$FMADD^XLFDT(DT,(0-CDOW))
+5 SET RTHRU=$$FMADD^XLFDT(DT,(6-CDOW))
+6 IF RTY="T"
QUIT
+7 IF RTY="L"
Begin DoDot:1
+8 SET RTHRU=$$FMADD^XLFDT(RFROM,-1)
+9 SET RFROM=$$FMADD^XLFDT(RTHRU,-6)
End DoDot:1
+10 IF RTY="N"
Begin DoDot:1
+11 SET RFROM=$$FMADD^XLFDT(RTHRU,1)
+12 SET RTHRU=$$FMADD^XLFDT(RFROM,6)
End DoDot:1
+13 QUIT
+14 ;
MON(RTY) ;EP Range for a month
+1 NEW BQMON,CYR,PYR,NYR,BQDTE,EDAY
+2 ; RTY = 'L' is Last, 'T' is This, and 'N' is Next
+3 SET BQMON=$EXTRACT(DT,4,5)
SET CYR=$EXTRACT(DT,1,3)
SET PYR=CYR-1
SET NYR=CYR+1
+4 SET BQDTE=$PIECE($TEXT(MQ+BQMON),";;",2)
+5 SET BQMON=$PIECE(BQDTE,U,1)
+6 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+7 IF RTY="N"
Begin DoDot:1
+8 SET RFROM=@($PIECE(BQDTE,U,4))_$PIECE(BQDTE,U,3)_"01"
+9 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+10 SET RTHRU=@($PIECE(BQDTE,U,4))_$PIECE(BQDTE,U,3)_$PIECE(EDAY,U,+$PIECE(BQDTE,U,3))
End DoDot:1
+11 IF RTY="L"
Begin DoDot:1
+12 SET RFROM=@($PIECE(BQDTE,U,6))_$PIECE(BQDTE,U,5)_"01"
+13 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+14 SET RTHRU=@($PIECE(BQDTE,U,6))_$PIECE(BQDTE,U,5)_$PIECE(EDAY,U,+$PIECE(BQDTE,U,5))
End DoDot:1
+15 IF RTY="T"
Begin DoDot:1
+16 SET RFROM=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_"01"
+17 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+18 SET RTHRU=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_$PIECE(EDAY,U,+$PIECE(BQDTE,U,1))
End DoDot:1
+19 QUIT
+20 ;
IMON ;EP
+1 NEW CMON,CT,NUM
+2 SET CMON=$ORDER(^BQIPROV("AD",""),-1)
SET CT=1
+3 SET RTHRU=CMON
+4 SET NUM=$PIECE(VAL,"Last ",2)
SET NUM=$PIECE(NUM," Months",1)
+5 SET FMON=CMON
FOR N=CT+1:1:NUM
SET FMON=$ORDER(^BQIPROV("AD",FMON),-1)
IF FMON=""
QUIT
SET RFROM=FMON
+6 QUIT
+7 ;
IWEEK ;EP
+1 NEW CT,NUM,CWK,FWK
+2 SET CWK=$ORDER(^BQIPROV("AE",""),-1)
SET CT=1
+3 IF CWK=""
SET CWK=$ORDER(^BQITEAM("AC",""),-1)
+4 SET RTHRU=CWK
+5 SET NUM=$PIECE(VAL,"Last ",2)
SET NUM=$PIECE(NUM," Weeks",1)
+6 IF $DATA(^BQIPROV("AE"))
SET FWK=CWK
FOR N=CT+1:1:NUM
SET FWK=$ORDER(^BQIPROV("AE",FWK),-1)
IF FWK=""
QUIT
SET RFROM=FWK
QUIT
+7 IF $DATA(^BQITEAM("AC"))
SET FWK=CWK
FOR N=CT+1:1:NUM
SET FWK=$ORDER(^BQITEAM("AC",FWK),-1)
IF FWK=""
QUIT
SET RFROM=FWK
+8 QUIT
+9 ;
YR(RTY) ;EP Range for a year
+1 NEW CYR,PYR,NYR
+2 SET CYR=$EXTRACT(DT,1,3)
SET PYR=CYR-1
SET NYR=CYR+1
+3 IF RTY="L"
SET RFROM=PYR_"0101"
SET RTHRU=PYR_"1231"
+4 IF RTY="T"
SET RFROM=CYR_"0101"
SET RTHRU=CYR_"1231"
+5 IF RTY="N"
SET RFROM=NYR_"0101"
SET RTHRU=NYR_"1231"
+6 IF ENT="IPC"
SET RFROM=$EXTRACT(RFROM,1,5)_"00"
SET RTHRU=$EXTRACT(RTHRU,1,5)_"00"
+7 QUIT
+8 ;
GQTR(NUM) ;EP Range for a GPRA quarter
+1 NEW CYR,PYR
+2 SET CYR=$EXTRACT(DT,1,3)
SET PYR=CYR-1
+3 IF NUM=1
SET RFROM=PYR_"0701"
SET RTHRU=PYR_"0930"
+4 IF NUM=2
SET RFROM=PYR_"1001"
SET RTHRU=PYR_"1231"
+5 IF NUM=3
SET RFROM=CYR_"0101"
SET RTHRU=CYR_"0331"
+6 IF NUM=4
SET RFROM=CYR_"0401"
SET RTHRU=CYR_"0630"
+7 QUIT
+8 ;
CQTR(NUM) ;EP Range for a Calendar quarter
+1 NEW CYR,PYR,NYR
+2 SET CYR=$EXTRACT(DT,1,3)
+3 IF NUM=1
SET RFROM=CYR_"0101"
SET RTHRU=CYR_"0331"
+4 IF NUM=2
SET RFROM=CYR_"0401"
SET RTHRU=CYR_"0630"
+5 IF NUM=3
SET RFROM=CYR_"0701"
SET RTHRU=CYR_"0930"
+6 IF NUM=4
SET RFROM=CYR_"1001"
SET RTHRU=CYR_"1231"
+7 QUIT
+8 ;
FQTR(NUM) ;EP Range for a Fiscal quarter
+1 NEW CYR,PYR
+2 SET CYR=$EXTRACT(DT,1,3)
SET PYR=CYR-1
+3 IF NUM=1
SET RFROM=PYR_"1001"
SET RTHRU=PYR_"1231"
+4 IF NUM=2
SET RFROM=CYR_"0101"
SET RTHRU=CYR_"0331"
+5 IF NUM=3
SET RFROM=CYR_"0401"
SET RTHRU=CYR_"0630"
+6 IF NUM=4
SET RFROM=CYR_"0701"
SET RTHRU=CYR_"0930"
+7 QUIT
+8 ;
MQ ;
+1 ;;01^CYR^02^CYR^12^PYR
+2 ;;02^CYR^03^CYR^01^CYR
+3 ;;03^CYR^04^CYR^02^CYR
+4 ;;04^CYR^05^CYR^03^CYR
+5 ;;05^CYR^06^CYR^04^CYR
+6 ;;06^CYR^07^CYR^05^CYR
+7 ;;07^CYR^08^CYR^06^CYR
+8 ;;08^CYR^09^CYR^07^CYR
+9 ;;09^CYR^10^CYR^08^CYR
+10 ;;10^CYR^11^CYR^09^CYR
+11 ;;11^CYR^12^CYR^10^CYR
+12 ;;12^CYR^01^NYR^11^CYR
