BARRSLDX.m

BARRSLDX ; IHS/SD/POT - Utility to selec DX Parameters

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**23,24**;OCT 26,2005;Build 69

 ; IHS/SD/POTT NEW ROUTINE BAR1.8*23

 ; IHS/SD/POTT HEAT150941 02/09/14 Allow ALL DX9/10 - BAR1.8*24

 ;                        if no DX selected: show ALL DX of ALL available coding systems - BAR1.8*24

 ; *********************************************************************

 ;

DXTYPE ;OBSOLETE CALL: HEAT150941 BAR1.8*24

 Q

 K BARY("DXTYPE")

 K DIRUT,DIR,Y

 S Y=$$DIR^XBDIR("S^P:Search in Primary DX Only;A:All DX","Select Search DX type ","","","","",1)

 K DA

 Q Y

 ;

GETDX(BARIEN) ;

 ;

 ; Search ALL diagnosis; fill array BARARRDG

 ; BAR3PDXP=1 indicates primary DX

 ; 

 NEW BARDBG,BARCNT,BAR3PDX,BARPRMDX,BAR3PDXP,BAR3PLOC,BAR3PIEN,BAR3PDUZ,BARARRDG,I ;ARRAY OF DG

 S BARDBG=0 ;P.OTT

 S BAR3PLOC=$$FIND3PB^BARUTL(DUZ(2),BARIEN)

 I BAR3PLOC="" Q

 S BAR3PIEN=$P(BAR3PLOC,",",2)

 S BAR3PDUZ=$P(BAR3PLOC,",")

 S BARCNT=0

 S (BAR3PDX,BARPRMDX)=0 F  S BAR3PDX=$O(^ABMDBILL(BAR3PDUZ,BAR3PIEN,17,BAR3PDX)) Q:'+BAR3PDX  D  ;Q:+BARPRMDX

 . S BARCNT=BARCNT+1

 . S BAR3PDXP=$P($G(^ABMDBILL(BAR3PDUZ,BAR3PIEN,17,BAR3PDX,0)),U,2)

 . I $T(+1^ICDEX)="" S BARDXCOD=$P($$ICDDX^ICDCODE(BAR3PDX,""),U,2) ;DX CODE - OLD CODE: NOT WORKING FOR ICD10

 . I $T(+1^ICDEX)]"" S BARDXCOD=$P($$ICDDX^ICDEX(BAR3PDX,""),U,2) ;DX CODE - NEW API SUPPORTS BOTH ICD9/10

 . ;;;I BAR3PDXP=1 I BARY("DXTYPE")="P" S BARARRDG("ALL_CODE",BARCNT)=BARDXCOD Q  ;old code HEAT150941 BAR1.8*24

 . I BAR3PDXP=1 S BARARRDG("ALL_CODE",BARCNT)=BARDXCOD Q  ;PROCESS ONLY PRIMARY DXs!!! HEAT150941

 . ;OLD CODE: S BARARRDG("ALL_CODE",BARCNT)=BARDXCOD ;HEAT150941

 . Q

 K BAR("DX") ;clear array

 M BAR("DX")=BARARRDG("ALL_CODE") ;fill array

 Q

 ;COUNT DXs WHICH CONTAIN X

 ;

LIST(BARX,BARVERB) ;

 NEW BARX0,BARXL

 ;RETURNS : BARCNT

 S BARXL=$L(X),BARCNT=0,BARX0=X_" "

 F I=1:1 S BARX0=$O(^ICD9("AB",BARX0)) Q:BARX0=""  Q:$E(BARX0,1,BARXL)'=BARX  D

 . S BARCNT=BARCNT+1

 . I BARVERB W !,BARCNT,". ",BARX0

 I 'BARVERB Q

 I 'BARCNT W " NO MATCHING DXs." Q

 W "  ",BARCNT," MATCHING DXs FOUND."

 Q

BARRSLDX  ; IHS/SD/POT - Utility to selec DX Parameters

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**23,24**;OCT 26,2005;Build 69

 +2       ; IHS/SD/POTT NEW ROUTINE BAR1.8*23

 +3       ; IHS/SD/POTT HEAT150941 02/09/14 Allow ALL DX9/10 - BAR1.8*24

 +4       ;                        if no DX selected: show ALL DX of ALL available coding systems - BAR1.8*24

 +5       ; *********************************************************************

 +6       ;

DXTYPE    ;OBSOLETE CALL: HEAT150941 BAR1.8*24

 +1        QUIT 

 +2        KILL BARY("DXTYPE")

 +3        KILL DIRUT,DIR,Y

 +4        SET Y=$$DIR^XBDIR("S^P:Search in Primary DX Only;A:All DX","Select Search DX type ","","","","",1)

 +5        KILL DA

 +6        QUIT Y

 +7       ;

GETDX(BARIEN) ;

 +1       ;

 +2       ; Search ALL diagnosis; fill array BARARRDG

 +3       ; BAR3PDXP=1 indicates primary DX

 +4       ; 

 +5       ;ARRAY OF DG

           NEW BARDBG,BARCNT,BAR3PDX,BARPRMDX,BAR3PDXP,BAR3PLOC,BAR3PIEN,BAR3PDUZ,BARARRDG,I

 +6       ;P.OTT

           SET BARDBG=0

 +7        SET BAR3PLOC=$$FIND3PB^BARUTL(DUZ(2),BARIEN)

 +8        IF BAR3PLOC=""

               QUIT 

 +9        SET BAR3PIEN=$PIECE(BAR3PLOC,",",2)

 +10       SET BAR3PDUZ=$PIECE(BAR3PLOC,",")

 +11       SET BARCNT=0

 +12      ;Q:+BARPRMDX

           SET (BAR3PDX,BARPRMDX)=0

           FOR 

               SET BAR3PDX=$ORDER(^ABMDBILL(BAR3PDUZ,BAR3PIEN,17,BAR3PDX))

               IF '+BAR3PDX

                   QUIT 

               Begin DoDot:1

 +13               SET BARCNT=BARCNT+1

 +14               SET BAR3PDXP=$PIECE($GET(^ABMDBILL(BAR3PDUZ,BAR3PIEN,17,BAR3PDX,0)),U,2)

 +15      ;DX CODE - OLD CODE: NOT WORKING FOR ICD10

                   IF $TEXT(+1^ICDEX)=""

                       SET BARDXCOD=$PIECE($$ICDDX^ICDCODE(BAR3PDX,""),U,2)

 +16      ;DX CODE - NEW API SUPPORTS BOTH ICD9/10

                   IF $TEXT(+1^ICDEX)]""

                       SET BARDXCOD=$PIECE($$ICDDX^ICDEX(BAR3PDX,""),U,2)

 +17      ;;;I BAR3PDXP=1 I BARY("DXTYPE")="P" S BARARRDG("ALL_CODE",BARCNT)=BARDXCOD Q  ;old code HEAT150941 BAR1.8*24

 +18      ;PROCESS ONLY PRIMARY DXs!!! HEAT150941

                   IF BAR3PDXP=1

                       SET BARARRDG("ALL_CODE",BARCNT)=BARDXCOD

                       QUIT 

 +19      ;OLD CODE: S BARARRDG("ALL_CODE",BARCNT)=BARDXCOD ;HEAT150941

 +20               QUIT 

               End DoDot:1

 +21      ;clear array

           KILL BAR("DX")

 +22      ;fill array

           MERGE BAR("DX")=BARARRDG("ALL_CODE")

 +23       QUIT 

 +24      ;COUNT DXs WHICH CONTAIN X

 +25      ;

LIST(BARX,BARVERB) ;

 +1        NEW BARX0,BARXL

 +2       ;RETURNS : BARCNT

 +3        SET BARXL=$LENGTH(X)

           SET BARCNT=0

           SET BARX0=X_" "

 +4        FOR I=1:1

               SET BARX0=$ORDER(^ICD9("AB",BARX0))

               IF BARX0=""

                   QUIT 

               IF $EXTRACT(BARX0,1,BARXL)'=BARX

                   QUIT 

               Begin DoDot:1

 +5                SET BARCNT=BARCNT+1

 +6                IF BARVERB

                       WRITE !,BARCNT,". ",BARX0

               End DoDot:1

 +7        IF 'BARVERB

               QUIT 

 +8        IF 'BARCNT

               WRITE " NO MATCHING DXs."

               QUIT 

 +9        WRITE "  ",BARCNT," MATCHING DXs FOUND."

 +10       QUIT