Routine: IBDF18A2

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)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF18A2   2760     printed  Mar 13, 2025@21:55:54                                                                                                                                                                                                    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

IBDF18A2.m