- ICPTAPIU ;ALB/DEK/KER - CPT UTILITIES FOR APIS ; 04/18/2004
- ;;6.0;CPT/HCPCS;**1,6,12,14,16,19,22**;May 19, 1997
- ;
- ; External References
- ; DBIA 10011 ^DIWP
- ; DBIA 10029 ^DIWW
- ; DBIA 10103 $$DT^XLFDT
- ;
- CPTDIST() ; Distribution Date
- ; Input: none (extrinsic variable)
- ; Output: returns DISTRIBUTION DATE, date codes effective in Austin
- Q $P($G(^DIC(81.2,1,0)),"^",2)
- ;
- CAT(CAT,DFN) ; Return CATEGORY NAME given IEN
- ; Input: CAT = category ien REQUIRED
- ; DFN - not in use but included in anticipation of future need
- ;
- ; Output: STR = CATEGORY NAME^SOURCE (C or H)^MAJOR CATEGORY IEN^MAJOR CATEGORY NAME
- ; STR = -1^error message, if error condition occurred
- ;
- N CATN,STR,MCATIEN,MCATNM
- S (MCATIEN,MCATNM)=""
- I $G(CAT)="" S STR="-1^NO CATEGORY SELECTED" G CATQ
- I '$G(CAT) S STR="-1^INVALID CATEGORY FORMAT" G CATQ
- S STR=$G(^DIC(81.1,+CAT,0))
- I '$L(STR) S STR="-1^NO SUCH CATEGORY" G CATQ
- I $P(STR,"^",2)="" S STR="-1^TYPE OF CATEGORY UNSPECIFIED" G CATQ
- S CATN=$P(STR,"^")
- I $P(STR,"^",2)="m" S MCATNM=CATN,MCATIEN=+CAT
- I $P(STR,"^",2)="s" D
- . S MCATIEN=$P(STR,"^",3)
- . I MCATIEN S MCATNM=$P($G(^DIC(81.1,MCATIEN,0)),"^")
- S STR=CATN_"^"_$P(STR,"^",6)_"^"_MCATIEN_"^"_MCATNM
- CATQ Q STR
- ;
- NUM(Y) ; Convert CPT/HCPCS Code to Numeric
- ; Convert HCPCS to $A() of Alpha _ Numeric Portion
- ;
- ; Input: Y - CPT or HCPCS code
- ;
- ; Output: 'plussed' value for CPT code,
- ; numeric for HCPCS based on $A of 1st character (alpha)
- ; concatenated with the 4-digit portion of code
- ;
- ; **This does not convert to ien**
- ; This converts to a numeric that may be used for range sorting
- ;
- ;Q $S(Y:+Y,1:$A(Y)_$E(Y,2,5))
- ; modified in 2002 to handle few CPT codes that end with "T"
- ; needed to add multiplier to create higher and unique number
- ; e.g. "Z9999"=909999 and "0001T"=8400001
- Q $S(Y?1.N:+Y,Y?4N1A:$A($E(Y,5))*10_$E(Y,1,4),1:$A(Y)_$E(Y,2,5))
- ;
- COPY ; API to Print Copyright Information
- ;
- N DIR,DIWL,DIWR,DIWF,VARR,VAXX,X
- Q:'$D(^DIC(81.2,1)) K ^UTILITY($J,"W")
- W !!! S DIWL=1,DIWR=80,DIWF="W"
- F VARR=0:0 S VARR=$O(^DIC(81.2,1,1,VARR)) Q:VARR'>0 S VAXX=^(VARR,0),X=VAXX D ^DIWP
- D:$D(VAXX) ^DIWW
- Q
- ;
- STATCHK(CODE,CDT) ; Check Status of CPT Code or Modifier
- ; Input:
- ; CODE - CPT Code/Modifier REQUIRED
- ; CDT - Date to screen against (FileMan format, default = today)
- ;
- ; Output:
- ; 2-Piece String containing the status of the code/modifier
- ; and the IEN if the code/modifier exists, else -1.
- ; The following are possible outputs:
- ; 1 ^ IEN Active Code/Modifier
- ; 0 ^ IEN Inactive Code/Modifier
- ; 0 ^ -1 Code/Modifier not Found
- ;
- ; This API requires the ACT Cross-Reference
- ; ^ICPT("ACT",<code>,<status>,<date>,<ien>)
- ; ^DIC(81.3,"ACT",<code>,<status>,<date>,<ien>)
- ;
- N ICPTC,ICPTD,ICPTIEN,ICPTA,ICPTI,X,ICPTG,ICPTR,ICPTD
- S ICPTC=$G(CODE) Q:'$L(ICPTC) "0^-1"
- ; Case 1: Not Valid 0^-1
- ; Fails Pattern Match for Code
- S ICPTG=$$GBL^ICPTSUPT(ICPTC) Q:ICPTG="" "0^-1"
- ; Case 2: Never Active 0^IEN
- ; No In/Active Date
- S ICPTD=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT($G(CDT))),ICPTD=ICPTD+.001
- S ICPTR=$$ACT(ICPTG,ICPTC,1,ICPTD),ICPTA=$O(@(ICPTR_")"),-1)
- I '$L(ICPTA) D Q X
- . S ICPTA=$O(@(ICPTR_")")),X="0^-1" Q:'$L(ICPTA)
- . S ICPTR=$$ACT(ICPTG,ICPTC,1,ICPTA)
- . S ICPTIEN=$O(@(ICPTR_",0)")) S:+ICPTIEN<1 ICPTIEN=-1
- . S X="0^"_ICPTIEN
- ; Case 3: Active, Never Inactive 1^IEN
- ; Has an Activation Date
- ; No Inactivation Date
- S ICPTR=$$ACT(ICPTG,ICPTC,0,ICPTD),ICPTI=$O(@(ICPTR_")"),-1)
- I $L(ICPTA),'$L(ICPTI) D Q X
- . S ICPTR=$$ACT(ICPTG,ICPTC,1,ICPTA),ICPTIEN=$O(@(ICPTR_",0)"))
- . S X=$S(+ICPTIEN=0:"0^-1",1:"1^"_ICPTIEN)
- ; Case 4: Active, but later Inactivated 0^IEN
- ; Has an In/Activation Date
- I $L(ICPTA),$L(ICPTI),ICPTI>ICPTA,ICPTI<ICPTD D Q X
- . S ICPTR=$$ACT(ICPTG,ICPTC,0,ICPTI),ICPTIEN=$O(@(ICPTR_",0)"))
- . S X=$S(+ICPTIEN=0:"0^-1",1:"0^"_ICPTIEN)
- ; Case 5: Active, and not later Inactivated 1^IEN
- ; Has an In/Activation Date
- ; Has a Newer Activation Date
- I $L(ICPTA),$L(ICPTI),ICPTI'>ICPTA D Q X
- . S ICPTR=$$ACT(ICPTG,ICPTC,0,ICPTI),ICPTIEN=$O(@(ICPTR_",1)"))
- . S X=$S(+$O(@(ICPTR_",0)"))=0:"0^-1",1:"1^"_ICPTIEN)
- ; Case 6: Fails Time Test 0^-1
- Q ("0^"_$S(+($G(ICPTIEN))>0:+($G(ICPTIEN)),1:"-1"))
- ;
- NEXT(CODE) ; Next CPT Code or Modifier (active or inactive)
- ; Input:
- ; CODE = CPT Code/Modifier REQUIRED
- ;
- ; Output:
- ; The Next CPT Code/Modifier, Null if none
- ;
- N ICPTC,ICPTG
- S ICPTC=$G(CODE) Q:'$L(ICPTC) ""
- S ICPTG=$$GBL^ICPTSUPT(ICPTC) Q:'$L(ICPTG) ""
- S ICPTC=$O(@(ICPTG_"""BA"","""_ICPTC_" "")"))
- Q $S(ICPTC="":"",1:$E(ICPTC,1,$L(ICPTC)-1))
- ;
- PREV(CODE) ; Previous CPT Code or Modifier (active or inactive)
- ; Input:
- ; CODE = CPT Code/Modifier REQUIRED
- ;
- ; Output:
- ; The Previous CPT Code/Modifier, Null if none
- ;
- N ICPTC,ICPTG
- S ICPTC=$G(CODE) Q:'$L(ICPTC) ""
- S ICPTG=$$GBL^ICPTSUPT(ICPTC) Q:'$L(ICPTG) ""
- S ICPTC=$O(@(ICPTG_"""BA"","""_ICPTC_" "")"),-1)
- Q $S(ICPTC="":"",1:$E(ICPTC,1,$L(ICPTC)-1))
- ;
- HIST(CODE,ARY) ; Activation History
- ; Input:
- ; CODE - CPT Code or Modifier REQUIRED
- ; .ARY - Array, passed by Reference REQUIRED
- ;
- ; Output: Mirrors ARY(0) (or, -1 on error)
- ; ARY(0) = Number of Activation History Entries
- ; ARY(<date>) = status where: 1 is Active
- ; ARY("IEN") = <ien>
- ;
- Q:$G(CODE)="" -1
- N ICPTC,ICPTI,ICPTN,ICPTD,ICPTG,ICPTF,ICPTO
- S ICPTG=$$GBL^ICPTSUPT(CODE) Q:'$L(ICPTG) -1
- S ICPTI=$O(@(ICPTG_"""BA"","""_CODE_" "",0)")) Q:'$L(ICPTI) -1
- S ARY("IEN")=ICPTI,ICPTO="" M ICPTO=@(ICPTG_ICPTI_",60)")
- K ICPT0("B") S ARY(0)=+($P($G(ICPTO(0)),"^",4))
- S:+ARY(0)=0 ARY(0)=-1 K:ARY(0)=-1 ARY("IEN")
- S (ICPTI,ICPTC)=0 F S ICPTI=$O(ICPTO(ICPTI)) Q:+ICPTI=0 D
- . S ICPTD=$P($G(ICPTO(ICPTI,0)),"^",1) Q:+ICPTD=0
- . S ICPTF=$P($G(ICPTO(ICPTI,0)),"^",2) Q:'$L(ICPTF)
- . S ICPTC=ICPTC+1,ARY(0)=ICPTC,ARY(ICPTD)=ICPTF
- Q ARY(0)
- ;
- PERIOD(CODE,ARY) ; return Activation/Inactivation Period in ARY
- ;
- ; Output: ARY(0) = String: IEN^Selectable
- ;
- ; Where the pieces are:
- ;
- ; 1 Internal Entry Number of code in ^ICPT or ^DIC(81.3,
- ; 2 0:unselectable; 1:selectable
- ;
- ; ARY(Activation Date) = Inactivation Date^Short Name
- ; Where the Short Name is the Versioned text (field 1 of the 61
- ; multiple), and the text is versioned as follows:
- ;
- ; Period is active - Versioned text for TODAY's date
- ; Period is inactive - Versioned text for inactivation date
- ;
- ; or
- ;
- ; -1^0 (no period or error)
- ;
- I $G(CODE)="" S ARY(0)="-1^0" Q
- N ICPTC,ICPTI,ICPTA,ICPTG,ICPTF,ICPTBA,ICPTBI,ICPTST,ICPTS,ICPTZ,ICPTV,ICPTN,ICPTCA
- S ICPTG=$$GBL^ICPTSUPT(CODE) I ICPTG="" S ARY(0)="-1^0" Q
- S ICPTC=$O(@(ICPTG_"""BA"","""_CODE_" "",0)")) I ICPTC="" S ARY(0)="-1^0" Q
- S (ARY(0),ICPTC)=+ICPTC,ICPTZ=$G(@(ICPTG_ICPTC_",0)")),ICPTS=$P(ICPTZ,"^",2)
- S $P(ARY(0),"^",2)=$S(ICPTG="^ICPT(":$P(ICPTZ,"^",6)'="L",1:$P(ICPTZ,"^",4)'="V")
- S (ICPTA,ICPTBA)=0,ICPTG=ICPTG_ICPTC_",60,"
- ; Versioned text for TODAY
- S ICPTN=$$VST^ICPTCOD(ICPTC,$$DT^XLFDT,ICPTG)
- F Q:ICPTBA D
- . S ICPTA=$O(@(ICPTG_"""B"","_ICPTA_")"))
- . I ICPTA="" S ICPTBA=1 Q
- . S ICPTF=$O(@(ICPTG_"""B"","_ICPTA_",0)"))
- . I '+ICPTF S ICPTBA=1 Q
- . S ICPTST=$P($G(@(ICPTG_ICPTF_",0)")),"^",2)
- . Q:'ICPTST ;outer loop looks for active
- . ; Versioned text for activation date
- . S ICPTV=$$VST^ICPTCOD(ICPTC,ICPTA,ICPTG),ICPTCA=1
- . S ARY(ICPTA)="^"_ICPTS,ICPTBI=0,ICPTI=ICPTA
- . S:$L(ICPTV) $P(ARY(ICPTA),"^",2)=ICPTV
- . F Q:ICPTBI D
- . . S ICPTI=$O(@(ICPTG_"""B"","_ICPTI_")"))
- . . ; If no inactivation date for ICPTA then use TODAY's text
- . . I ICPTI="" S ARY(ICPTA)="^"_ICPTN,(ICPTBI,ICPTBA)=1 Q
- . . S ICPTF=$O(@(ICPTG_"""B"","_ICPTI_",0)"))
- . . ; If no effective date ICPTF for ICPTI then use TODAY's text
- . . I '+ICPTF S ARY(ICPTA)="^"_ICPTN,(ICPTBI,ICPTBA)=1 Q
- . . S ICPTST=$P($G(@(ICPTG_ICPTF_",0)")),"^",2)
- . . ; If Status ICPTST not Inactive then use TODAY's text
- . . I ICPTST S ARY(ICPTA)="^"_ICPTN,ICPTBI=1 Q
- . . ; Versioned text for inactive date
- . . S ICPTV=$$VST^ICPTCOD(ICPTC,ICPTI,ICPTG)
- . . S $P(ARY(ICPTA),"^")=ICPTI
- . . S:$L(ICPTV) $P(ARY(ICPTA),"^",2)=ICPTV
- . . S ICPTCA=0,ICPTBI=1,ICPTA=ICPTI
- Q
- ;
- ACT(ICPTG,ICPTC,ICPTS,ICPTD) ; return "ACT" root
- Q ICPTG_"""ACT"","""_ICPTC_" "","_ICPTS_","_ICPTD
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICPTAPIU 8881 printed Jan 18, 2025@02:46:53 Page 2
- ICPTAPIU ;ALB/DEK/KER - CPT UTILITIES FOR APIS ; 04/18/2004
- +1 ;;6.0;CPT/HCPCS;**1,6,12,14,16,19,22**;May 19, 1997
- +2 ;
- +3 ; External References
- +4 ; DBIA 10011 ^DIWP
- +5 ; DBIA 10029 ^DIWW
- +6 ; DBIA 10103 $$DT^XLFDT
- +7 ;
- CPTDIST() ; Distribution Date
- +1 ; Input: none (extrinsic variable)
- +2 ; Output: returns DISTRIBUTION DATE, date codes effective in Austin
- +3 QUIT $PIECE($GET(^DIC(81.2,1,0)),"^",2)
- +4 ;
- CAT(CAT,DFN) ; Return CATEGORY NAME given IEN
- +1 ; Input: CAT = category ien REQUIRED
- +2 ; DFN - not in use but included in anticipation of future need
- +3 ;
- +4 ; Output: STR = CATEGORY NAME^SOURCE (C or H)^MAJOR CATEGORY IEN^MAJOR CATEGORY NAME
- +5 ; STR = -1^error message, if error condition occurred
- +6 ;
- +7 NEW CATN,STR,MCATIEN,MCATNM
- +8 SET (MCATIEN,MCATNM)=""
- +9 IF $GET(CAT)=""
- SET STR="-1^NO CATEGORY SELECTED"
- GOTO CATQ
- +10 IF '$GET(CAT)
- SET STR="-1^INVALID CATEGORY FORMAT"
- GOTO CATQ
- +11 SET STR=$GET(^DIC(81.1,+CAT,0))
- +12 IF '$LENGTH(STR)
- SET STR="-1^NO SUCH CATEGORY"
- GOTO CATQ
- +13 IF $PIECE(STR,"^",2)=""
- SET STR="-1^TYPE OF CATEGORY UNSPECIFIED"
- GOTO CATQ
- +14 SET CATN=$PIECE(STR,"^")
- +15 IF $PIECE(STR,"^",2)="m"
- SET MCATNM=CATN
- SET MCATIEN=+CAT
- +16 IF $PIECE(STR,"^",2)="s"
- Begin DoDot:1
- +17 SET MCATIEN=$PIECE(STR,"^",3)
- +18 IF MCATIEN
- SET MCATNM=$PIECE($GET(^DIC(81.1,MCATIEN,0)),"^")
- End DoDot:1
- +19 SET STR=CATN_"^"_$PIECE(STR,"^",6)_"^"_MCATIEN_"^"_MCATNM
- CATQ QUIT STR
- +1 ;
- NUM(Y) ; Convert CPT/HCPCS Code to Numeric
- +1 ; Convert HCPCS to $A() of Alpha _ Numeric Portion
- +2 ;
- +3 ; Input: Y - CPT or HCPCS code
- +4 ;
- +5 ; Output: 'plussed' value for CPT code,
- +6 ; numeric for HCPCS based on $A of 1st character (alpha)
- +7 ; concatenated with the 4-digit portion of code
- +8 ;
- +9 ; **This does not convert to ien**
- +10 ; This converts to a numeric that may be used for range sorting
- +11 ;
- +12 ;Q $S(Y:+Y,1:$A(Y)_$E(Y,2,5))
- +13 ; modified in 2002 to handle few CPT codes that end with "T"
- +14 ; needed to add multiplier to create higher and unique number
- +15 ; e.g. "Z9999"=909999 and "0001T"=8400001
- +16 QUIT $SELECT(Y?1.N:+Y,Y?4N1A:$ASCII($EXTRACT(Y,5))*10_$EXTRACT(Y,1,4),1:$ASCII(Y)_$EXTRACT(Y,2,5))
- +17 ;
- COPY ; API to Print Copyright Information
- +1 ;
- +2 NEW DIR,DIWL,DIWR,DIWF,VARR,VAXX,X
- +3 if '$DATA(^DIC(81.2,1))
- QUIT
- KILL ^UTILITY($JOB,"W")
- +4 WRITE !!!
- SET DIWL=1
- SET DIWR=80
- SET DIWF="W"
- +5 FOR VARR=0:0
- SET VARR=$ORDER(^DIC(81.2,1,1,VARR))
- if VARR'>0
- QUIT
- SET VAXX=^(VARR,0)
- SET X=VAXX
- DO ^DIWP
- +6 if $DATA(VAXX)
- DO ^DIWW
- +7 QUIT
- +8 ;
- STATCHK(CODE,CDT) ; Check Status of CPT Code or Modifier
- +1 ; Input:
- +2 ; CODE - CPT Code/Modifier REQUIRED
- +3 ; CDT - Date to screen against (FileMan format, default = today)
- +4 ;
- +5 ; Output:
- +6 ; 2-Piece String containing the status of the code/modifier
- +7 ; and the IEN if the code/modifier exists, else -1.
- +8 ; The following are possible outputs:
- +9 ; 1 ^ IEN Active Code/Modifier
- +10 ; 0 ^ IEN Inactive Code/Modifier
- +11 ; 0 ^ -1 Code/Modifier not Found
- +12 ;
- +13 ; This API requires the ACT Cross-Reference
- +14 ; ^ICPT("ACT",<code>,<status>,<date>,<ien>)
- +15 ; ^DIC(81.3,"ACT",<code>,<status>,<date>,<ien>)
- +16 ;
- +17 NEW ICPTC,ICPTD,ICPTIEN,ICPTA,ICPTI,X,ICPTG,ICPTR,ICPTD
- +18 SET ICPTC=$GET(CODE)
- if '$LENGTH(ICPTC)
- QUIT "0^-1"
- +19 ; Case 1: Not Valid 0^-1
- +20 ; Fails Pattern Match for Code
- +21 SET ICPTG=$$GBL^ICPTSUPT(ICPTC)
- if ICPTG=""
- QUIT "0^-1"
- +22 ; Case 2: Never Active 0^IEN
- +23 ; No In/Active Date
- +24 SET ICPTD=$SELECT($GET(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT($GET(CDT)))
- SET ICPTD=ICPTD+.001
- +25 SET ICPTR=$$ACT(ICPTG,ICPTC,1,ICPTD)
- SET ICPTA=$ORDER(@(ICPTR_")"),-1)
- +26 IF '$LENGTH(ICPTA)
- Begin DoDot:1
- +27 SET ICPTA=$ORDER(@(ICPTR_")"))
- SET X="0^-1"
- if '$LENGTH(ICPTA)
- QUIT
- +28 SET ICPTR=$$ACT(ICPTG,ICPTC,1,ICPTA)
- +29 SET ICPTIEN=$ORDER(@(ICPTR_",0)"))
- if +ICPTIEN<1
- SET ICPTIEN=-1
- +30 SET X="0^"_ICPTIEN
- End DoDot:1
- QUIT X
- +31 ; Case 3: Active, Never Inactive 1^IEN
- +32 ; Has an Activation Date
- +33 ; No Inactivation Date
- +34 SET ICPTR=$$ACT(ICPTG,ICPTC,0,ICPTD)
- SET ICPTI=$ORDER(@(ICPTR_")"),-1)
- +35 IF $LENGTH(ICPTA)
- IF '$LENGTH(ICPTI)
- Begin DoDot:1
- +36 SET ICPTR=$$ACT(ICPTG,ICPTC,1,ICPTA)
- SET ICPTIEN=$ORDER(@(ICPTR_",0)"))
- +37 SET X=$SELECT(+ICPTIEN=0:"0^-1",1:"1^"_ICPTIEN)
- End DoDot:1
- QUIT X
- +38 ; Case 4: Active, but later Inactivated 0^IEN
- +39 ; Has an In/Activation Date
- +40 IF $LENGTH(ICPTA)
- IF $LENGTH(ICPTI)
- IF ICPTI>ICPTA
- IF ICPTI<ICPTD
- Begin DoDot:1
- +41 SET ICPTR=$$ACT(ICPTG,ICPTC,0,ICPTI)
- SET ICPTIEN=$ORDER(@(ICPTR_",0)"))
- +42 SET X=$SELECT(+ICPTIEN=0:"0^-1",1:"0^"_ICPTIEN)
- End DoDot:1
- QUIT X
- +43 ; Case 5: Active, and not later Inactivated 1^IEN
- +44 ; Has an In/Activation Date
- +45 ; Has a Newer Activation Date
- +46 IF $LENGTH(ICPTA)
- IF $LENGTH(ICPTI)
- IF ICPTI'>ICPTA
- Begin DoDot:1
- +47 SET ICPTR=$$ACT(ICPTG,ICPTC,0,ICPTI)
- SET ICPTIEN=$ORDER(@(ICPTR_",1)"))
- +48 SET X=$SELECT(+$ORDER(@(ICPTR_",0)"))=0:"0^-1",1:"1^"_ICPTIEN)
- End DoDot:1
- QUIT X
- +49 ; Case 6: Fails Time Test 0^-1
- +50 QUIT ("0^"_$SELECT(+($GET(ICPTIEN))>0:+($GET(ICPTIEN)),1:"-1"))
- +51 ;
- NEXT(CODE) ; Next CPT Code or Modifier (active or inactive)
- +1 ; Input:
- +2 ; CODE = CPT Code/Modifier REQUIRED
- +3 ;
- +4 ; Output:
- +5 ; The Next CPT Code/Modifier, Null if none
- +6 ;
- +7 NEW ICPTC,ICPTG
- +8 SET ICPTC=$GET(CODE)
- if '$LENGTH(ICPTC)
- QUIT ""
- +9 SET ICPTG=$$GBL^ICPTSUPT(ICPTC)
- if '$LENGTH(ICPTG)
- QUIT ""
- +10 SET ICPTC=$ORDER(@(ICPTG_"""BA"","""_ICPTC_" "")"))
- +11 QUIT $SELECT(ICPTC="":"",1:$EXTRACT(ICPTC,1,$LENGTH(ICPTC)-1))
- +12 ;
- PREV(CODE) ; Previous CPT Code or Modifier (active or inactive)
- +1 ; Input:
- +2 ; CODE = CPT Code/Modifier REQUIRED
- +3 ;
- +4 ; Output:
- +5 ; The Previous CPT Code/Modifier, Null if none
- +6 ;
- +7 NEW ICPTC,ICPTG
- +8 SET ICPTC=$GET(CODE)
- if '$LENGTH(ICPTC)
- QUIT ""
- +9 SET ICPTG=$$GBL^ICPTSUPT(ICPTC)
- if '$LENGTH(ICPTG)
- QUIT ""
- +10 SET ICPTC=$ORDER(@(ICPTG_"""BA"","""_ICPTC_" "")"),-1)
- +11 QUIT $SELECT(ICPTC="":"",1:$EXTRACT(ICPTC,1,$LENGTH(ICPTC)-1))
- +12 ;
- HIST(CODE,ARY) ; Activation History
- +1 ; Input:
- +2 ; CODE - CPT Code or Modifier REQUIRED
- +3 ; .ARY - Array, passed by Reference REQUIRED
- +4 ;
- +5 ; Output: Mirrors ARY(0) (or, -1 on error)
- +6 ; ARY(0) = Number of Activation History Entries
- +7 ; ARY(<date>) = status where: 1 is Active
- +8 ; ARY("IEN") = <ien>
- +9 ;
- +10 if $GET(CODE)=""
- QUIT -1
- +11 NEW ICPTC,ICPTI,ICPTN,ICPTD,ICPTG,ICPTF,ICPTO
- +12 SET ICPTG=$$GBL^ICPTSUPT(CODE)
- if '$LENGTH(ICPTG)
- QUIT -1
- +13 SET ICPTI=$ORDER(@(ICPTG_"""BA"","""_CODE_" "",0)"))
- if '$LENGTH(ICPTI)
- QUIT -1
- +14 SET ARY("IEN")=ICPTI
- SET ICPTO=""
- MERGE ICPTO=@(ICPTG_ICPTI_",60)")
- +15 KILL ICPT0("B")
- SET ARY(0)=+($PIECE($GET(ICPTO(0)),"^",4))
- +16 if +ARY(0)=0
- SET ARY(0)=-1
- if ARY(0)=-1
- KILL ARY("IEN")
- +17 SET (ICPTI,ICPTC)=0
- FOR
- SET ICPTI=$ORDER(ICPTO(ICPTI))
- if +ICPTI=0
- QUIT
- Begin DoDot:1
- +18 SET ICPTD=$PIECE($GET(ICPTO(ICPTI,0)),"^",1)
- if +ICPTD=0
- QUIT
- +19 SET ICPTF=$PIECE($GET(ICPTO(ICPTI,0)),"^",2)
- if '$LENGTH(ICPTF)
- QUIT
- +20 SET ICPTC=ICPTC+1
- SET ARY(0)=ICPTC
- SET ARY(ICPTD)=ICPTF
- End DoDot:1
- +21 QUIT ARY(0)
- +22 ;
- PERIOD(CODE,ARY) ; return Activation/Inactivation Period in ARY
- +1 ;
- +2 ; Output: ARY(0) = String: IEN^Selectable
- +3 ;
- +4 ; Where the pieces are:
- +5 ;
- +6 ; 1 Internal Entry Number of code in ^ICPT or ^DIC(81.3,
- +7 ; 2 0:unselectable; 1:selectable
- +8 ;
- +9 ; ARY(Activation Date) = Inactivation Date^Short Name
- +10 ; Where the Short Name is the Versioned text (field 1 of the 61
- +11 ; multiple), and the text is versioned as follows:
- +12 ;
- +13 ; Period is active - Versioned text for TODAY's date
- +14 ; Period is inactive - Versioned text for inactivation date
- +15 ;
- +16 ; or
- +17 ;
- +18 ; -1^0 (no period or error)
- +19 ;
- +20 IF $GET(CODE)=""
- SET ARY(0)="-1^0"
- QUIT
- +21 NEW ICPTC,ICPTI,ICPTA,ICPTG,ICPTF,ICPTBA,ICPTBI,ICPTST,ICPTS,ICPTZ,ICPTV,ICPTN,ICPTCA
- +22 SET ICPTG=$$GBL^ICPTSUPT(CODE)
- IF ICPTG=""
- SET ARY(0)="-1^0"
- QUIT
- +23 SET ICPTC=$ORDER(@(ICPTG_"""BA"","""_CODE_" "",0)"))
- IF ICPTC=""
- SET ARY(0)="-1^0"
- QUIT
- +24 SET (ARY(0),ICPTC)=+ICPTC
- SET ICPTZ=$GET(@(ICPTG_ICPTC_",0)"))
- SET ICPTS=$PIECE(ICPTZ,"^",2)
- +25 SET $PIECE(ARY(0),"^",2)=$SELECT(ICPTG="^ICPT(":$PIECE(ICPTZ,"^",6)'="L",1:$PIECE(ICPTZ,"^",4)'="V")
- +26 SET (ICPTA,ICPTBA)=0
- SET ICPTG=ICPTG_ICPTC_",60,"
- +27 ; Versioned text for TODAY
- +28 SET ICPTN=$$VST^ICPTCOD(ICPTC,$$DT^XLFDT,ICPTG)
- +29 FOR
- if ICPTBA
- QUIT
- Begin DoDot:1
- +30 SET ICPTA=$ORDER(@(ICPTG_"""B"","_ICPTA_")"))
- +31 IF ICPTA=""
- SET ICPTBA=1
- QUIT
- +32 SET ICPTF=$ORDER(@(ICPTG_"""B"","_ICPTA_",0)"))
- +33 IF '+ICPTF
- SET ICPTBA=1
- QUIT
- +34 SET ICPTST=$PIECE($GET(@(ICPTG_ICPTF_",0)")),"^",2)
- +35 ;outer loop looks for active
- if 'ICPTST
- QUIT
- +36 ; Versioned text for activation date
- +37 SET ICPTV=$$VST^ICPTCOD(ICPTC,ICPTA,ICPTG)
- SET ICPTCA=1
- +38 SET ARY(ICPTA)="^"_ICPTS
- SET ICPTBI=0
- SET ICPTI=ICPTA
- +39 if $LENGTH(ICPTV)
- SET $PIECE(ARY(ICPTA),"^",2)=ICPTV
- +40 FOR
- if ICPTBI
- QUIT
- Begin DoDot:2
- +41 SET ICPTI=$ORDER(@(ICPTG_"""B"","_ICPTI_")"))
- +42 ; If no inactivation date for ICPTA then use TODAY's text
- +43 IF ICPTI=""
- SET ARY(ICPTA)="^"_ICPTN
- SET (ICPTBI,ICPTBA)=1
- QUIT
- +44 SET ICPTF=$ORDER(@(ICPTG_"""B"","_ICPTI_",0)"))
- +45 ; If no effective date ICPTF for ICPTI then use TODAY's text
- +46 IF '+ICPTF
- SET ARY(ICPTA)="^"_ICPTN
- SET (ICPTBI,ICPTBA)=1
- QUIT
- +47 SET ICPTST=$PIECE($GET(@(ICPTG_ICPTF_",0)")),"^",2)
- +48 ; If Status ICPTST not Inactive then use TODAY's text
- +49 IF ICPTST
- SET ARY(ICPTA)="^"_ICPTN
- SET ICPTBI=1
- QUIT
- +50 ; Versioned text for inactive date
- +51 SET ICPTV=$$VST^ICPTCOD(ICPTC,ICPTI,ICPTG)
- +52 SET $PIECE(ARY(ICPTA),"^")=ICPTI
- +53 if $LENGTH(ICPTV)
- SET $PIECE(ARY(ICPTA),"^",2)=ICPTV
- +54 SET ICPTCA=0
- SET ICPTBI=1
- SET ICPTA=ICPTI
- End DoDot:2
- End DoDot:1
- +55 QUIT
- +56 ;
- ACT(ICPTG,ICPTC,ICPTS,ICPTD) ; return "ACT" root
- +1 QUIT ICPTG_"""ACT"","""_ICPTC_" "","_ICPTS_","_ICPTD