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 Dec 13, 2024@01:45:39 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
