IBDF18A2 ;WISC/TN - ENCOUNTER FORM - utilities for PCE ;04/30/03
;;3.0;AUTOMATED INFO COLLECTION SYS;**51,55,63,66**;APR 30, 2003;Build 5
;
; Reference to $$STATCHK^ICDEX supported by ICR #5747
;
QUIT ;Call at CHKLST
;
CHKLST ;Create a new list to pass to calling packages.
;The new array will have CPT or ICD codes which
;are valid for the encounter date passed.
;
;CALLED BY: IBDF18A
;
;Quit if no date is passed.
S ENCDATE=$G(ENCDATE) I ENCDATE="" Q
;
NEW AA,CNT,CNT1,CNT2,MOD,TYPE,NODE,IBDCSYS,IBDIMPDA,IBDX
K ^TMP("IBDCSV",$J) S U="^"
;
S CNT=0,AA=0,TYPE="",NODE="MODIFIER"
S:PACKAGE="DG SELECT CPT PROCEDURE CODES" TYPE="CPT"
S:PACKAGE="DG SELECT ICD-9 DIAGNOSIS CODE" TYPE="ICD"
S:PACKAGE="DG SELECT ICD DIAGNOSIS CODES" TYPE="ICD"
S:PACKAGE="DG SELECT ICD-10 DIAGNOSIS COD" TYPE="ICD10"
S:PACKAGE="DG SELECT VISIT TYPE CPT PROCE" TYPE="CPT"
S:PACKAGE="GMP INPUT CLINIC COMMON PROBLE" TYPE="ICD"
S:PACKAGE="GMP PATIENT ACTIVE PROBLEMS" TYPE="ICD"
;
I TYPE="" D Q
. K @ARY
. S @ARY@(0)=1
. S @ARY@(1)="^AICS ERROR - Missing code type for "_PACKAGE
;
;Make copy of array and kill the original
M ^TMP("IBDCSV",$J)=@ARY KILL @ARY
;
S CNT=0,AA=0
F S AA=$O(^TMP("IBDCSV",$J,AA)) Q:'AA D
. ;
. I $E(^TMP("IBDCSV",$J,AA))="^" S CNT=CNT+1,@ARY@(CNT)=^TMP("IBDCSV",$J,AA) Q ;header
. ;
. S CODE=$P(^TMP("IBDCSV",$J,AA),U) I CODE="" Q
. ;
. ;Validate the CPT code for the date passed
. I TYPE="CPT" D Q
. . I $P($$CPT^ICPTCOD(CODE,ENCDATE),U,7)=1 D
. . . S CNT=CNT+1,@ARY@(CNT)=^TMP("IBDCSV",$J,AA)
. . . ;
. . . ;Check for modifiers.
. . . I '$G(^TMP("IBDCSV",$J,AA,NODE,0)) Q
. . . ;
. . . S CNT1=^TMP("IBDCSV",$J,AA,NODE,0)
. . . F CNT2=1:1:CNT1 S MOD=^TMP("IBDCSV",$J,AA,NODE,CNT2) D
. . . . ;
. . . . ;If the status is 1 for the modifier
. . . . I $P($$MOD^ICPTMOD(MOD,"E",ENCDATE),U,7)=1 D
. . . . . S @ARY@(CNT,NODE,CNT2)=^TMP("IBDCSV",$J,AA,NODE,CNT2)
. . . . . S @ARY@(CNT,NODE,0)=CNT2
. . . . ;
. ;Validate the ICD code for the date passed
. S IBDIMPDA=$$IMPDATE^IBDUTICD("10D")
. I TYPE="ICD10",ENCDATE'<IBDIMPDA D Q
. . ; IBD*3*66 - Call $$STATCHK^ICDEX to speed up dx status retrieval
. . S IBDX=$$STATCHK^ICDEX(CODE,ENCDATE,30) I +IBDX>0 D ;Active
. . . S CNT=CNT+1,@ARY@(CNT)=^TMP("IBDCSV",$J,AA)
. I TYPE="ICD" D ;This includes BOTH DG SELECT ICD-9 DIAGNOSIS CODES and DG SELECT ICD DIAGNOSIS CODES dependent upon ENCDATE
. . S IBDCSYS=$S(ENCDATE<IBDIMPDA:1,1:30)
. . ; IBD*3*66 - Call $$STATCHK^ICDEX to speed up dx status retrieval
. . S IBDX=$$STATCHK^ICDEX(CODE,ENCDATE,IBDCSYS) I +IBDX>0 D ;Active
. . . S CNT=CNT+1,@ARY@(CNT)=^TMP("IBDCSV",$J,AA)
;
S @ARY@(0)=CNT
K ^TMP("IBDCSV",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF18A2 2760 printed Apr 09, 2024@20:58:52 Page 2
IBDF18A2 ;WISC/TN - ENCOUNTER FORM - utilities for PCE ;04/30/03
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**51,55,63,66**;APR 30, 2003;Build 5
+2 ;
+3 ; Reference to $$STATCHK^ICDEX supported by ICR #5747
+4 ;
+5 ;Call at CHKLST
QUIT
+6 ;
CHKLST ;Create a new list to pass to calling packages.
+1 ;The new array will have CPT or ICD codes which
+2 ;are valid for the encounter date passed.
+3 ;
+4 ;CALLED BY: IBDF18A
+5 ;
+6 ;Quit if no date is passed.
+7 SET ENCDATE=$GET(ENCDATE)
IF ENCDATE=""
QUIT
+8 ;
+9 NEW AA,CNT,CNT1,CNT2,MOD,TYPE,NODE,IBDCSYS,IBDIMPDA,IBDX
+10 KILL ^TMP("IBDCSV",$JOB)
SET U="^"
+11 ;
+12 SET CNT=0
SET AA=0
SET TYPE=""
SET NODE="MODIFIER"
+13 if PACKAGE="DG SELECT CPT PROCEDURE CODES"
SET TYPE="CPT"
+14 if PACKAGE="DG SELECT ICD-9 DIAGNOSIS CODE"
SET TYPE="ICD"
+15 if PACKAGE="DG SELECT ICD DIAGNOSIS CODES"
SET TYPE="ICD"
+16 if PACKAGE="DG SELECT ICD-10 DIAGNOSIS COD"
SET TYPE="ICD10"
+17 if PACKAGE="DG SELECT VISIT TYPE CPT PROCE"
SET TYPE="CPT"
+18 if PACKAGE="GMP INPUT CLINIC COMMON PROBLE"
SET TYPE="ICD"
+19 if PACKAGE="GMP PATIENT ACTIVE PROBLEMS"
SET TYPE="ICD"
+20 ;
+21 IF TYPE=""
Begin DoDot:1
+22 KILL @ARY
+23 SET @ARY@(0)=1
+24 SET @ARY@(1)="^AICS ERROR - Missing code type for "_PACKAGE
End DoDot:1
QUIT
+25 ;
+26 ;Make copy of array and kill the original
+27 MERGE ^TMP("IBDCSV",$JOB)=@ARY
KILL @ARY
+28 ;
+29 SET CNT=0
SET AA=0
+30 FOR
SET AA=$ORDER(^TMP("IBDCSV",$JOB,AA))
if 'AA
QUIT
Begin DoDot:1
+31 ;
+32 ;header
IF $EXTRACT(^TMP("IBDCSV",$JOB,AA))="^"
SET CNT=CNT+1
SET @ARY@(CNT)=^TMP("IBDCSV",$JOB,AA)
QUIT
+33 ;
+34 SET CODE=$PIECE(^TMP("IBDCSV",$JOB,AA),U)
IF CODE=""
QUIT
+35 ;
+36 ;Validate the CPT code for the date passed
+37 IF TYPE="CPT"
Begin DoDot:2
+38 IF $PIECE($$CPT^ICPTCOD(CODE,ENCDATE),U,7)=1
Begin DoDot:3
+39 SET CNT=CNT+1
SET @ARY@(CNT)=^TMP("IBDCSV",$JOB,AA)
+40 ;
+41 ;Check for modifiers.
+42 IF '$GET(^TMP("IBDCSV",$JOB,AA,NODE,0))
QUIT
+43 ;
+44 SET CNT1=^TMP("IBDCSV",$JOB,AA,NODE,0)
+45 FOR CNT2=1:1:CNT1
SET MOD=^TMP("IBDCSV",$JOB,AA,NODE,CNT2)
Begin DoDot:4
+46 ;
+47 ;If the status is 1 for the modifier
+48 IF $PIECE($$MOD^ICPTMOD(MOD,"E",ENCDATE),U,7)=1
Begin DoDot:5
+49 SET @ARY@(CNT,NODE,CNT2)=^TMP("IBDCSV",$JOB,AA,NODE,CNT2)
+50 SET @ARY@(CNT,NODE,0)=CNT2
End DoDot:5
+51 ;
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
+52 ;Validate the ICD code for the date passed
+53 SET IBDIMPDA=$$IMPDATE^IBDUTICD("10D")
+54 IF TYPE="ICD10"
IF ENCDATE'<IBDIMPDA
Begin DoDot:2
+55 ; IBD*3*66 - Call $$STATCHK^ICDEX to speed up dx status retrieval
+56 ;Active
SET IBDX=$$STATCHK^ICDEX(CODE,ENCDATE,30)
IF +IBDX>0
Begin DoDot:3
+57 SET CNT=CNT+1
SET @ARY@(CNT)=^TMP("IBDCSV",$JOB,AA)
End DoDot:3
End DoDot:2
QUIT
+58 ;This includes BOTH DG SELECT ICD-9 DIAGNOSIS CODES and DG SELECT ICD DIAGNOSIS CODES dependent upon ENCDATE
IF TYPE="ICD"
Begin DoDot:2
+59 SET IBDCSYS=$SELECT(ENCDATE<IBDIMPDA:1,1:30)
+60 ; IBD*3*66 - Call $$STATCHK^ICDEX to speed up dx status retrieval
+61 ;Active
SET IBDX=$$STATCHK^ICDEX(CODE,ENCDATE,IBDCSYS)
IF +IBDX>0
Begin DoDot:3
+62 SET CNT=CNT+1
SET @ARY@(CNT)=^TMP("IBDCSV",$JOB,AA)
End DoDot:3
End DoDot:2
End DoDot:1
+63 ;
+64 SET @ARY@(0)=CNT
+65 KILL ^TMP("IBDCSV",$JOB)
+66 QUIT
