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

BQIDCAH1.m

Go to the documentation of this file. 
  1. 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
  1.  Q
  1.  ;
  1. ACHK(IEN) ;EP - Age check
  1.  NEW AGE,PAGE,TYP1,TYP2,OP1,OP2,AVAL1,AVAL2,PTYP,PVAL
  1.  ;S AGE=$$GET1^DIQ(9000001,IEN_",",1102.99,"E")
  1.  S AGE=$$AGE^BQIAGE(IEN)
  1.  I AGE="" Q
  1.  ;S PAGE=$$GET1^DIQ(9000001,IEN_",",1102.98,"E")
  1.  S PAGE=$$AGE^BQIAGE(IEN,,1)
  1.  ;
  1.  S TYP1=$E(CRIT1,$L(CRIT1)-2,$L(CRIT1)),OP1=$E(CRIT1,1,1)
  1.  I TYP1'="YRS",TYP1'="MOS",TYP1'="DYS" S TYP1="YRS"
  1.  S AVAL1=$E(CRIT1,2,$L(CRIT1)-3)
  1.  I $E(OP1,1,1)="'" S OP1=$E(CRIT1,1,2),AVAL1=$E(CRIT1,3,$L(CRIT1)-3)
  1.  ;
  1.  ; If not inclusive or exclusive, then only one criteria
  1.  I $G(CRIT2)="" D
  1.  . ;  If the search is in years, can just use the AGE value
  1.  . I TYP1="YRS" D  Q
  1.  .. S AVAL1=$$STRIP^XLFSTR(CRIT1,TYP1)
  1.  .. I @(AGE_AVAL1) S @TGLOB@(IEN)="" Q
  1.  . ; If the search is not in years, must check the PRINTED AGE value
  1.  . ; for those ages in months and days
  1.  . S PVAL=$P(PAGE," ",1),PTYP=$P(PAGE," ",2)
  1.  . ;S AVAL1=$E(CRIT1,2,$L(CRIT1)-3)
  1.  . ; Check the operand for a 'not' and set operand and criteria value appropriately
  1.  . I $E(OP1,1,1)="'" S AVAL1=$E(CRIT1,3,$L(CRIT1)-3)
  1.  . ; If the criteria qualifier type is not equal to the printed age qualifier type
  1.  . I TYP1'=PTYP D  Q
  1.  .. ; if the operand is less than or less than/equal, depending on the
  1.  .. ; criteria qualifier, certain print age qualifiers should be included or
  1.  .. ; excluded from the check
  1.  .. I OP1="<"!(OP1="'>") D
  1.  ... I TYP1="MOS",PTYP="YRS" Q
  1.  ... I TYP1="DYS",PTYP="YRS"!(PTYP="MOS") Q
  1.  ... S @TGLOB@(IEN)=""
  1.  .. ; if the operand is greater than or greater than/equal, depending on the
  1.  .. ; criteria qualifier, certain print age qualifiers should be included or
  1.  .. ; excluded from the check
  1.  .. I OP1=">"!(OP1="'<") D
  1.  ... I TYP1="MOS",PTYP="DYS" Q
  1.  ... S @TGLOB@(IEN)=""
  1.  . ; if the criteria qualifier and the print age qualifer is the same, then
  1.  . ; simple arithmetic check can be done based on the operand
  1.  . I @(PVAL_OP1_AVAL1) S @TGLOB@(IEN)=""
  1.  ;
  1.  ;  If inclusive or exclusive criteria is used
  1.  I $G(CRIT2)'="" D
  1.  . S TYP2=$E(CRIT2,$L(CRIT2)-2,$L(CRIT2)),OP2=$E(CRIT2,1,1)
  1.  . I TYP2'="YRS",TYP2'="MOS",TYP2'="DYS" S TYP2="YRS"
  1.  . S AVAL2=$E(CRIT2,2,$L(CRIT2)-3)
  1.  . I $E(OP2,1,1)="'" S OP2=$E(CRIT2,1,2),AVAL2=$E(CRIT2,3,$L(CRIT2)-3)
  1.  . ; If both criteria qualifiers are years, then AGE value can be checked
  1.  . I TYP1="YRS",TYP2="YRS" D  Q
  1.  .. S AVAL1=$$STRIP^XLFSTR(CRIT1,TYP1)
  1.  .. S AVAL2=$$STRIP^XLFSTR(CRIT2,TYP2)
  1.  .. ; if operand contains a 'not' value, then it is inclusive and the value
  1.  .. ; must have both criteria as 'true'
  1.  .. I OP1["'",OP2["'" I @(AGE_AVAL1),@(AGE_AVAL2) S @TGLOB@(IEN)="" Q
  1.  .. ; if operand does not contain a 'not' value, then it is exclusive and the
  1.  .. ; value must have one criteria as 'true'
  1.  .. I OP1'["'",OP2'["'" D  Q
  1.  ... I @(AGE_AVAL1) S @TGLOB@(IEN)="" Q
  1.  ... I @(AGE_AVAL2) S @TGLOB@(IEN)="" Q
  1.  . ;
  1.  . ; Can't compare non compatible qualifiers
  1.  . I TYP1="YRS",TYP2'="YRS" Q
  1.  . I TYP1="MOS",TYP2="DYS" Q
  1.  . ;
  1.  . S PVAL=$P(PAGE," ",1),PTYP=$P(PAGE," ",2)
  1.  . I PTYP=TYP1,PTYP=TYP2 D  Q
  1.  .. S AVAL1=$$STRIP^XLFSTR(CRIT1,TYP1)
  1.  .. S AVAL2=$$STRIP^XLFSTR(CRIT2,TYP2)
  1.  .. I OP1["'",OP2["'" I @(PVAL_AVAL1),@(PVAL_AVAL2) S @TGLOB@(IEN)="" Q
  1.  .. I OP1'["'",OP2'["'" D  Q
  1.  ... I @(PVAL_AVAL1) S @TGLOB@(IEN)="" Q
  1.  ... I @(PVAL_AVAL2) S @TGLOB@(IEN)="" Q
  1.  . ; Inclusive check
  1.  . I OP1="'<" D
  1.  .. I TYP1="MOS" D
  1.  ... I PTYP="DYS" Q
  1.  ... I PTYP="MOS",@(PVAL_OP1_AVAL1) D
  1.  .... I TYP2="YRS" S @TGLOB@(IEN)="" Q
  1.  ... I PTYP=TYP2,@(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
  1.  .. I TYP1="DYS" D
  1.  ... I PTYP="DYS",@(PVAL_OP1_AVAL1) D
  1.  .... I TYP2'="DYS" S @TGLOB@(IEN)="" Q
  1.  ... I PTYP=TYP2,@(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
  1.  . ; Exclusive check
  1.  . I OP1="<" D
  1.  .. I TYP1="DYS" D
  1.  ... I TYP2="DYS" D
  1.  .... I PTYP="DYS" D
  1.  ..... I @(PVAL_OP1_AVAL1) S @TGLOB@(IEN)="" Q
  1.  ..... I @(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
  1.  .... I PTYP="MOS"!(PTYP="YRS") S @TGLOB@(IEN)="" Q
  1.  ... I TYP2="MOS" D
  1.  .... I PTYP="DYS",@(PVAL_OP1_AVAL1) S @TGLOB@(IEN)="" Q
  1.  .... I PTYP="MOS",@(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
  1.  .... I PTYP="YRS" S @TGLOB@(IEN)="" Q
  1.  ... I TYP2="YRS" D
  1.  .... I PTYP="DYS",@(PVAL_OP1_AVAL1) S @TGLOB@(IEN)="" Q
  1.  .... I PTYP="MOS" Q
  1.  .... I PTYP="YRS",@(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
  1.  .. I TYP1="MOS" D
  1.  ... I TYP2="DYS" Q
  1.  ... I TYP2="MOS" D
  1.  .... I PTYP="DYS" S @TGLOB@(IEN)="" Q
  1.  .... I PTYP="MOS" D
  1.  ..... I @(PVAL_OP1_AVAL1) S @TGLOB@(IEN)="" Q
  1.  ..... I @(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
  1.  .... I PTYP="YRS" S @TGLOB@(IEN)="" Q
  1.  ... I TYP2="YRS" D
  1.  .... I PTYP="DYS" S @TGLOB@(IEN)="" Q
  1.  .... I PTYP="MOS",@(PVAL_OP1_AVAL1) S @TGLOB@(IEN)="" Q
  1.  .... I PTYP="YRS",@(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
  1.  .. I TYP1="YRS" D
  1.  ... I TYP2="DYS" Q
  1.  ... I TYP2="MOS" Q
  1.  ... I TYP2="YRS" D
  1.  .... I PTYP="DYS" S @TGLOB@(IEN)="" Q
  1.  .... I PTYP="MOS" S @TGLOB@(IEN)="" Q
  1.  .... I PTYP="YRS" D
  1.  ..... I @(PVAL_OP1_AVAL1) S @TGLOB@(IEN)="" Q
  1.  ..... I @(PVAL_OP2_AVAL2) S @TGLOB@(IEN)="" Q
  1.  Q
  1.  ;
  1. DIAG(FGLOB,TGLOB,DIAG,MPARMS) ;EP - Diagnosis Category search
  1.  NEW DXPT,CT,DFN,STAT,AVL,RCIEN
  1.  I $G(TGLOB)="" Q
  1.  I $G(DIAG)]"" D DXC
  1.  I $D(MPARMS("DXCAT")) D
  1.  . I DXOP="!" D  Q
  1.  .. S DIAG="" F  S DIAG=$O(MPARMS("DXCAT",DIAG)) Q:DIAG=""  D DXC
  1.  . I DXOP="&" D
  1.  .. S DIAG="",CT=0
  1.  .. F  S DIAG=$O(MPARMS("DXCAT",DIAG)) Q:DIAG=""  D
  1.  ... S CT=CT+1,IEN=""
  1.  ... F  S IEN=$O(^BQIREG("B",DIAG,IEN)) Q:IEN=""  D
  1.  .... S DFN=$P(^BQIREG(IEN,0),U,2)
  1.  .... S STAT=$P(^BQIREG(IEN,0),U,3)
  1.  .... ; Check for associated statuses
  1.  .... I '$D(APARMS),'$D(MAPARMS) S DXPT(DFN)=$G(DXPT(DFN))+1 Q
  1.  .... I $G(APARMS("DXCAT",DIAG,"DXSTAT"))'="" D  Q
  1.  ..... I STAT=$G(APARMS("DXCAT",DIAG,"DXSTAT")) S DXPT(DFN)=$G(DXPT(DFN))+1
  1.  .... S AVL=""
  1.  .... F  S AVL=$O(MAPARMS("DXCAT",DIAG,"DXSTAT",AVL)) Q:AVL=""  D
  1.  ..... I STAT=AVL S DXPT(DFN)=$G(DXPT(DFN))+1
  1.  . ;
  1.  . S IEN="" F  S IEN=$O(DXPT(IEN)) Q:IEN=""  I DXPT(IEN)'=CT K DXPT(IEN)
  1.  . I $G(FGLOB)="" S IEN="" F  S IEN=$O(DXPT(IEN)) Q:IEN=""  S @TGLOB@(IEN)=""
  1.  . I $G(FGLOB)'="" S IEN="" F  S IEN=$O(@FGLOB@(IEN)) Q:IEN=""  I $D(DXPT(IEN))>0 S @TGLOB@(IEN)=""
  1.  K MAPARMS("DXCAT")
  1.  Q
  1.  ;
  1. DXC ;
  1.  I $G(FGLOB)'="" D
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D
  1.  .. I $D(^BQIREG("C",IEN,DIAG)) D
  1.  ... S RCIEN=$O(^BQIREG("C",IEN,DIAG,""))
  1.  ... S STAT=$P(^BQIREG(RCIEN,0),U,3)
  1.  ... ;**Check for associated statuses
  1.  ... I '$D(APARMS("DXCAT",DIAG)),'$D(MAPARMS("DXCAT",DIAG)) S @TGLOB@(IEN)="" Q
  1.  ... ; I '$D(APARMS),'$D(MAPARMS) S @TGLOB@(IEN)="" Q
  1.  ... I $G(APARMS("DXCAT",DIAG,"DXSTAT"))'="" D  Q
  1.  .... I STAT=$G(APARMS("DXCAT",DIAG,"DXSTAT")) S @TGLOB@(IEN)=""
  1.  ... S AVL=""
  1.  ... F  S AVL=$O(MAPARMS("DXCAT",DIAG,"DXSTAT",AVL)) Q:AVL=""  D
  1.  .... I STAT=AVL S @TGLOB@(IEN)=""
  1.  ;
  1.  NEW DFN,IEN
  1.  I $G(FGLOB)="" D
  1.  . S IEN=""
  1.  . F  S IEN=$O(^BQIREG("B",DIAG,IEN)) Q:IEN=""  D
  1.  .. S DFN=$P(^BQIREG(IEN,0),U,2)
  1.  .. S STAT=$P(^BQIREG(IEN,0),U,3)
  1.  .. ;  Check for associated statuses
  1.  .. I '$D(APARMS),'$D(MAPARMS) S @TGLOB@(DFN)="" Q
  1.  .. I $G(APARMS("DXCAT",DIAG,"DXSTAT"))'="" D  Q
  1.  ... I STAT=$G(APARMS("DXCAT",DIAG,"DXSTAT")) S @TGLOB@(DFN)=""
  1.  .. I $D(MAPARMS("DXCAT",DIAG,"DXSTAT",STAT)) S @TGLOB@(DFN)=""
  1.  Q
  1.  ;
  1.  ;
  1. BEN(FGLOB,TGLOB,BEN,MPARMS) ;EP - Beneficiary search
  1.  I $G(TGLOB)="" Q
  1.  I $G(BEN)]"" D BEN1
  1.  I $D(MPARMS("BEN")) S BEN="" F  S BEN=$O(MPARMS("BEN",BEN)) Q:BEN=""  D BEN1
  1.  Q
  1.  ;
  1. BEN1 ;
  1.  I $G(FGLOB)'="" D  Q
  1.  . N IEN,BENPT
  1.  . S IEN=""
  1.  . F  S IEN=$O(@FGLOB@(IEN)) Q:'IEN  D
  1.  .. S BENPT=$$GET1^DIQ(9000001,IEN_",",1111,"I")
  1.  .. I BENPT=BEN S @TGLOB@(IEN)=""
  1.  ;
  1.  N DFN
  1.  S DFN=""
  1.  F  S DFN=$O(^AUPNPAT("AD",BEN,DFN)) Q:DFN=""  S @TGLOB@(DFN)=""
  1.  Q
  1.  ;
  1. RANGE(VAL,ENT,RTYP) ; EP - Load relative from and through dates when RANGE, LRANGE, MRANGE
  1.  ;                    parameter or filter has been selected.
  1.  ; Input:
  1.  ;   VAL - Range value - e.g. last week
  1.  ;   ENT - Entry in file 90506
  1.  ;   RTYP - Relative timeframe variable name
  1.  ;
  1.  Q:$G(VAL)=""
  1.  Q:$G(ENT)=""
  1.  N RNGIEN,CHOICE
  1.  S RNGIEN=$O(^BQI(90506,ENT,3,"B",RTYP,""))
  1.  I RNGIEN D  Q
  1.  . S CHOICE=$O(^BQI(90506,ENT,3,RNGIEN,3,"B",VAL,""))
  1.  . I CHOICE D  Q
  1.  .. N DA,IENS,EXEC
  1.  .. S DA=CHOICE,DA(1)=RNGIEN,DA(2)=ENT S IENS=$$IENS^DILF(.DA)
  1.  .. S EXEC=$$GET1^DIQ(90506.33,IENS,.02,"I")
  1.  .. Q:EXEC=""
  1.  .. I EXEC["RFROM="!(EXEC["RTHRU=") D  Q
  1.  ... S RFROM=$$DATE^BQIUL1($P($P(EXEC,"RFROM=",2),"~"))
  1.  ... S RTHRU=$$DATE^BQIUL1($P($P(EXEC,"RTHRU=",2),"~"))
  1.  .. X EXEC
  1.  . S TN=""
  1.  . F  S TN=$O(^BQI(90506.9,"B",VAL,TN)) Q:TN=""  D
  1.  .. I '$D(^BQI(90506.9,TN,1,"B",RTYP)) Q
  1.  .. I $P(^BQI(90506.9,TN,0),U,4)'="" D  Q
  1.  ... S RFROM=$$DATE^BQIUL1($P(^BQI(90506.9,TN,0),U,3))
  1.  ... S RTHRU=$$DATE^BQIUL1($P(^BQI(90506.9,TN,0),U,4))
  1.  .. S EXEC=$P(^BQI(90506.9,TN,0),U,5) I EXEC="" Q
  1.  .. X EXEC
  1.  ;
  1.  S TN=""
  1.  F  S TN=$O(^BQI(90506.9,"B",VAL,TN)) Q:TN=""  D
  1.  . I '$D(^BQI(90506.9,TN,1,"B",RTYP)) Q
  1.  . S EXEC=$P(^BQI(90506.9,TN,0),U,5)
  1.  . I EXEC'="" X EXEC
  1.  . I ENT="IPC" Q
  1.  . I $P(^BQI(90506.9,TN,0),U,4)'="" D
  1.  .. S RFROM=$$DATE^BQIUL1($P(^BQI(90506.9,TN,0),U,3))
  1.  .. S RTHRU=$$DATE^BQIUL1($P(^BQI(90506.9,TN,0),U,4))
  1.  Q
  1.  ;
  1. CUR(RTY) ;EP Range for a week
  1.  ; RTY = 'L' is Last, 'T' is This, and 'N' is Next
  1.  NEW CDOW
  1.  S CDOW=$$DOW^XLFDT(DT,1)
  1.  S RFROM=$$FMADD^XLFDT(DT,(0-CDOW))
  1.  S RTHRU=$$FMADD^XLFDT(DT,(6-CDOW))
  1.  I RTY="T" Q
  1.  I RTY="L" D
  1.  . S RTHRU=$$FMADD^XLFDT(RFROM,-1)
  1.  . S RFROM=$$FMADD^XLFDT(RTHRU,-6)
  1.  I RTY="N" D
  1.  . S RFROM=$$FMADD^XLFDT(RTHRU,1)
  1.  . S RTHRU=$$FMADD^XLFDT(RFROM,6)
  1.  Q
  1.  ;
  1. MON(RTY) ;EP Range for a month
  1.  NEW BQMON,CYR,PYR,NYR,BQDTE,EDAY
  1.  ; RTY = 'L' is Last, 'T' is This, and 'N' is Next
  1.  S BQMON=$E(DT,4,5),CYR=$E(DT,1,3),PYR=CYR-1,NYR=CYR+1
  1.  S BQDTE=$P($T(MQ+BQMON),";;",2)
  1.  S BQMON=$P(BQDTE,U,1)
  1.  I $L(BQMON)=1 S BQMON="0"_BQMON
  1.  I RTY="N" D
  1.  . S RFROM=@($P(BQDTE,U,4))_$P(BQDTE,U,3)_"01"
  1.  . S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
  1.  . S RTHRU=@($P(BQDTE,U,4))_$P(BQDTE,U,3)_$P(EDAY,U,+$P(BQDTE,U,3))
  1.  I RTY="L" D
  1.  . S RFROM=@($P(BQDTE,U,6))_$P(BQDTE,U,5)_"01"
  1.  . S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
  1.  . S RTHRU=@($P(BQDTE,U,6))_$P(BQDTE,U,5)_$P(EDAY,U,+$P(BQDTE,U,5))
  1.  I RTY="T" D
  1.  . S RFROM=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_"01"
  1.  . S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
  1.  . S RTHRU=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_$P(EDAY,U,+$P(BQDTE,U,1))
  1.  Q
  1.  ;
  1. IMON ;EP
  1.  NEW CMON,CT,NUM
  1.  S CMON=$O(^BQIPROV("AD",""),-1),CT=1
  1.  S RTHRU=CMON
  1.  S NUM=$P(VAL,"Last ",2),NUM=$P(NUM," Months",1)
  1.  S FMON=CMON F N=CT+1:1:NUM S FMON=$O(^BQIPROV("AD",FMON),-1) Q:FMON=""  S RFROM=FMON
  1.  Q
  1.  ;
  1. IWEEK ;EP
  1.  NEW CT,NUM,CWK,FWK
  1.  S CWK=$O(^BQIPROV("AE",""),-1),CT=1
  1.  I CWK="" S CWK=$O(^BQITEAM("AC",""),-1)
  1.  S RTHRU=CWK
  1.  S NUM=$P(VAL,"Last ",2),NUM=$P(NUM," Weeks",1)
  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
  1.  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
  1.  Q
  1.  ;
  1. YR(RTY) ;EP Range for a year
  1.  NEW CYR,PYR,NYR
  1.  S CYR=$E(DT,1,3),PYR=CYR-1,NYR=CYR+1
  1.  I RTY="L" S RFROM=PYR_"0101",RTHRU=PYR_"1231"
  1.  I RTY="T" S RFROM=CYR_"0101",RTHRU=CYR_"1231"
  1.  I RTY="N" S RFROM=NYR_"0101",RTHRU=NYR_"1231"
  1.  I ENT="IPC" S RFROM=$E(RFROM,1,5)_"00",RTHRU=$E(RTHRU,1,5)_"00"
  1.  Q
  1.  ;
  1. GQTR(NUM) ;EP Range for a GPRA quarter
  1.  NEW CYR,PYR
  1.  S CYR=$E(DT,1,3),PYR=CYR-1
  1.  I NUM=1 S RFROM=PYR_"0701",RTHRU=PYR_"0930"
  1.  I NUM=2 S RFROM=PYR_"1001",RTHRU=PYR_"1231"
  1.  I NUM=3 S RFROM=CYR_"0101",RTHRU=CYR_"0331"
  1.  I NUM=4 S RFROM=CYR_"0401",RTHRU=CYR_"0630"
  1.  Q
  1.  ;
  1. CQTR(NUM) ;EP Range for a Calendar quarter
  1.  NEW CYR,PYR,NYR
  1.  S CYR=$E(DT,1,3)
  1.  I NUM=1 S RFROM=CYR_"0101",RTHRU=CYR_"0331"
  1.  I NUM=2 S RFROM=CYR_"0401",RTHRU=CYR_"0630"
  1.  I NUM=3 S RFROM=CYR_"0701",RTHRU=CYR_"0930"
  1.  I NUM=4 S RFROM=CYR_"1001",RTHRU=CYR_"1231"
  1.  Q
  1.  ;
  1. FQTR(NUM) ;EP Range for a Fiscal quarter
  1.  NEW CYR,PYR
  1.  S CYR=$E(DT,1,3),PYR=CYR-1
  1.  I NUM=1 S RFROM=PYR_"1001",RTHRU=PYR_"1231"
  1.  I NUM=2 S RFROM=CYR_"0101",RTHRU=CYR_"0331"
  1.  I NUM=3 S RFROM=CYR_"0401",RTHRU=CYR_"0630"
  1.  I NUM=4 S RFROM=CYR_"0701",RTHRU=CYR_"0930"
  1.  Q
  1.  ;
  1. MQ ;
  1.  ;;01^CYR^02^CYR^12^PYR
  1.  ;;02^CYR^03^CYR^01^CYR
  1.  ;;03^CYR^04^CYR^02^CYR
  1.  ;;04^CYR^05^CYR^03^CYR
  1.  ;;05^CYR^06^CYR^04^CYR
  1.  ;;06^CYR^07^CYR^05^CYR
  1.  ;;07^CYR^08^CYR^06^CYR
  1.  ;;08^CYR^09^CYR^07^CYR
  1.  ;;09^CYR^10^CYR^08^CYR
  1.  ;;10^CYR^11^CYR^09^CYR
  1.  ;;11^CYR^12^CYR^10^CYR
  1.  ;;12^CYR^01^NYR^11^CYR