SROADX2.m

SROADX2 ;BIR/RJS - ASSOCIATED DIAGNOSIS FOR CODER AND VERIFY SCREENS ;09/12/05 12:01pm

 ;;3.0; Surgery ;**119,150,142**;24 Jun 93

PDXCHK(SRCODE) N SRYBAK,SRXBAK,DIR,SRQUIT,SRTEMP,DA

 Q:'$D(D0)

 I '$D(SRTN) N SRTN S SRTN=D0

 Q:D0=SRTN

 S ^TMP($J,"SRASOC",SRTN)=""

 M SRYBAK=Y

 I SRYBAK=1 S SRYBAK=""

 S DIR(0)="Y",SRXBAK=X,SRQUIT=0,SRKALL=0,Y=0

 S DIR("A",1)="The Procedure Associations may no longer be correct,"

 I SRCODE D

 .Q:$$PRLOOP(1)=0

 .I $P(XQY0,U)'="SROVER"&($P(XQY0,U)'="SRCODING EDIT") S DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu"

 .S DIR("A")="Delete PRINCIPAL Procedure Associations for this DX",DIR("B")="NO"

 .S:$$GET1^DIQ(130.18,D0_","_SRTN_",",3) DIR("B")="YES"

 .D ^DIR

 I 'SRCODE D

 .I $$PRLOOP(1)=0,$$OTLOOP(1)=0 Q

 .S DIR("A")="All Procedure Associations for this DX will be deleted. Continue",DIR("B")="NO"

 .D ^DIR S:'Y SRXBAK=SRYBAK,SRQUIT=1

 .S:Y SRKALL=1

 S:Y SRTEMP=$$PRLOOP(0)

 M Y=SRYBAK S X=SRXBAK

 I SRQUIT W !! Q

 K DIR

 D OTHCHK(SRCODE)

 K SRKALL,SRMATCH,DIR

 Q

OTHCHK(SRCODE) N OTH,DA,SRY,SRQUIT,SRYBAK,SRXBAK,DIR

 M SRYBAK=Y

 S SRQUIT=0,SRXBAK=X

 I 'SRKALL W ! D

 .Q:$$OTLOOP(1)=0

 .S DIR(0)="Y",DIR("A",1)="The OTHER Prodecure Associations may no longer be correct."

 .I SRCODE D

 ..I $P(XQY0,U)'="SROVER"&($P(XQY0,U)'="SRCODING EDIT") S DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu"

 ..S DIR("A")="Delete OTHER Procedure Associations for this DX",DIR("B")="NO"

 ..S:$$GET1^DIQ(130.18,D0_","_SRTN_",",3) DIR("B")="YES"

 ..D ^DIR W !!

 I Y!SRKALL D

 .N DA S OTH=0

 .F  S OTH=$O(^SRF(SRTN,13,OTH)) Q:'OTH  D

 ..S DA=0

 ..F  S DA=$O(^SRF(SRTN,13,OTH,"OADX",DA)) Q:'+DA  D

 ...I D0=^SRF(SRTN,13,OTH,"OADX",DA,0) D  Q

 ....D KOADX(SRTN,OTH)

 M Y=SRYBAK S X=SRXBAK

 Q

MSG Q:$D(SRFLG)

 Q:'$D(EMILY)

 D SRCMSG^SROADX1

 D SRCWRT^SROADX1

 Q

PRLOOP(SRCHK) N SRDX,SRMATCH S (SRDX,SRMATCH)=0

 F SRI=1:1 S SRDX=$O(^SRF(SRTN,"PADX",SRDX)) Q:'SRDX  D

 .I (D0=^SRF(SRTN,"PADX",SRDX,0))!($G(DA)=^SRF(SRTN,"PADX",SRDX,0)) S SRMATCH=1 Q

 I SRMATCH,'SRCHK D KPADX(SRTN)

 Q SRMATCH

OTLOOP(SRCHK) N SRDA,OTH,SRMATCH S (OTH,SRMATCH)=0

 F  S OTH=$O(^SRF(SRTN,13,OTH)) Q:'OTH  D

 .S SRDA=0

 .F  S SRDA=$O(^SRF(SRTN,13,OTH,"OADX",SRDA)) Q:'+SRDA  D

 ..I (D0=^SRF(SRTN,13,OTH,"OADX",SRDA,0))!($G(DA)=^SRF(SRTN,13,OTH,"OADX",SRDA,0)) D  Q

 ...I 'SRCHK D KOADX(SRTN,SRDA)

 ...S SRMATCH=1

 Q SRMATCH

DELASOC N DIR,Y,SRPR,SROT,SRXBAK

 S:'$D(SRTN)&$D(DA(1)) SRTN=DA(1)

 S:'$D(SRTN)&'$D(DA(1)) SRTN=DA

 I $D(^TMP($J,"SRASOC",SRTN)) K ^TMP($J,"SRASOC",SRTN) Q

 Q:$G(D0)=""

 S SRPR=$$PRLOOP(1),SROT=$$OTLOOP(1),SRXBAK=X

 I 'SRPR,'SROT Q

 S DIR(0)="FO",DIR("A")="Procedure Associations for this Diagnosis will be deleted. Continue"

 D ^DIR

 S SRPR=$$PRLOOP(0),SROT=$$OTLOOP(0)

 S X=SRXBAK

 Q

PRINASO(SRCODE) Q:$G(SRTN)=""!($G(X)="")

 N D0 S D0=0  D PDXCHK(SRCODE) K SRCODE Q

PRINASOD Q:$G(SRTN)=""!($G(X)="")

 I $D(^TMP($J,"SRASOC",SRTN)) K ^TMP($J,"SRASOC",SRTN) Q

 N D0 S D0=0  D DELASOC Q

PCPTASO(SRCODE) Q:$G(SRTN)=""!($G(X)="")

 I $G(D0)=""!('+$G(X)&(SRCODE))!('$D(^SRF(SRTN,"PADX"))) Q

 D:$$EDITWARN(SRCODE) KPADX(SRTN)

 K SRCODE

 Q

OCPTASO(SRCODE) Q:$G(SRTN)=""!($G(DA)="")!($G(X)="")

 I $G(D0)=""!('+$G(X)&(SRCODE))!('$D(^SRF(SRTN,13,DA,"OADX",0))) Q

 D:$$EDITWARN(SRCODE) KOADX(SRTN,DA)

 K SRCODE

 Q

EDITWARN(SRCODE) N SRYBAK,SRXBAK,DIR,SRY

 M SRYBAK=Y,SRDABAK=DA

 S DIR(0)="Y",DIR("B")="NO",SRXBAK=X,SRQUIT=0

 S DIR("A",1)="The Diagnosis to Procedure Associations may no longer be correct."

 I SRCODE D

 .I $P(XQY0,U)'="SROVER"&($P(XQY0,U)'="SRCODING EDIT") S DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu."

 .S DIR("A")="Delete Diagnosis Associations for this Procedure"

 .D ^DIR

 I 'SRCODE D

 .S DIR("A")="All DX Associations for this Procedure will be deleted. Continue"

 .D ^DIR

 .S:'Y SRXBAK=SRYBAK

 S X=SRXBAK,SRY=Y

 M Y=SRYBAK,DA=SRDABAK

 W !!

 Q SRY

KPADX(SRCN) ; kill all the principal cpt associated diagnosis codes

 N DA,DIK,SRX1,Y,SRXBAK

 S SRX1=0,DA(1)=SRCN,SRXBAK=X

 F  S SRX1=$O(^SRF(DA(1),"PADX",SRX1)) Q:'SRX1  D

 .S DA=SRX1,DA(1)=SRCN,DIK="^SRF("_DA(1)_",""PADX""," D ^DIK

 S X=SRXBAK

 Q

KOADX(SRCN,SRREC) ; kill other cpt associated diagnosis codes

 N DA,DIK,SRX1,Y,SRXBAK

 S SRX1=0,DA(2)=SRCN,SRXBAK=X

 F  S SRX1=$O(^SRF(DA(2),13,SRREC,"OADX",SRX1)) Q:'SRX1  D

 .S DA=SRX1,DA(1)=SRREC,DA(2)=SRCN,DIK="^SRF("_DA(2)_",13,"_DA(1)_",""OADX""," D ^DIK

 S X=SRXBAK

 Q

ADXCHK ; check the validity of associations and remove if diagnosis missing

 N SRDX,SRX,SRY,SRZ

 S SRDX=0

 I $D(^SRF(SRTN,13)) S SRX=0 D

 .F  S SRX=$O(^SRF(SRTN,13,SRX)) Q:'SRX  D

 ..I $D(^SRF(SRTN,13,SRX,"OADX")) S SRY=0 D

 ...F  S SRY=$O(^SRF(SRTN,13,SRX,"OADX",SRY)) Q:'SRY  D

 ....S SRDX=^SRF(SRTN,13,SRX,"OADX",SRY,0)

 ....I (SRDX'=0),'$D(^SRF(SRTN,15,SRDX,0)) D KOADX(SRTN,SRX)

 ....I (SRDX=0),($P($G(^SRF(SRTN,34)),U)=""),('$P($G(^SRF(SRTN,34)),U,2)) D KOADX(SRTN,SRX)

 I $D(^SRF(SRTN,"PADX")) S SRX=0 D

 .F  S SRX=$O(^SRF(SRTN,"PADX",SRX)) Q:'SRX  D

 ..S SRDX=^SRF(SRTN,"PADX",SRX,0)

 ..I (SRDX'=0),'$D(^SRF(SRTN,15,SRDX,0)) D KPADX(SRTN)

 I $O(^SRF(SRTN,"PADX",0)),(($P($G(^SRF(SRTN,34)),U)="")&('$P($G(^SRF(SRTN,34)),U,2)))!(($P($G(^SRF(SRTN,"OP")),U)="")&('$P($G(^SRF(SRTN,"OP")),U,2))) D KPADX(SRTN)

 Q

SROADX2   ;BIR/RJS - ASSOCIATED DIAGNOSIS FOR CODER AND VERIFY SCREENS ;09/12/05 12:01pm

 +1       ;;3.0; Surgery ;**119,150,142**;24 Jun 93

PDXCHK(SRCODE)  NEW SRYBAK,SRXBAK,DIR,SRQUIT,SRTEMP,DA

 +1        IF '$DATA(D0)

               QUIT 

 +2        IF '$DATA(SRTN)

               NEW SRTN

               SET SRTN=D0

 +3        IF D0=SRTN

               QUIT 

 +4        SET ^TMP($JOB,"SRASOC",SRTN)=""

 +5        MERGE SRYBAK=Y

 +6        IF SRYBAK=1

               SET SRYBAK=""

 +7        SET DIR(0)="Y"

           SET SRXBAK=X

           SET SRQUIT=0

           SET SRKALL=0

           SET Y=0

 +8        SET DIR("A",1)="The Procedure Associations may no longer be correct,"

 +9        IF SRCODE

               Begin DoDot:1

 +10               IF $$PRLOOP(1)=0

                       QUIT 

 +11               IF $PIECE(XQY0,U)'="SROVER"&($PIECE(XQY0,U)'="SRCODING EDIT")

                       SET DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu"

 +12               SET DIR("A")="Delete PRINCIPAL Procedure Associations for this DX"

                   SET DIR("B")="NO"

 +13               IF $$GET1^DIQ(130.18,D0_","_SRTN_",",3)

                       SET DIR("B")="YES"

 +14               DO ^DIR

               End DoDot:1

 +15       IF 'SRCODE

               Begin DoDot:1

 +16               IF $$PRLOOP(1)=0

                       IF $$OTLOOP(1)=0

                           QUIT 

 +17               SET DIR("A")="All Procedure Associations for this DX will be deleted. Continue"

                   SET DIR("B")="NO"

 +18               DO ^DIR

                   IF 'Y

                       SET SRXBAK=SRYBAK

                       SET SRQUIT=1

 +19               IF Y

                       SET SRKALL=1

               End DoDot:1

 +20       IF Y

               SET SRTEMP=$$PRLOOP(0)

 +21       MERGE Y=SRYBAK

           SET X=SRXBAK

 +22       IF SRQUIT

               WRITE !!

               QUIT 

 +23       KILL DIR

 +24       DO OTHCHK(SRCODE)

 +25       KILL SRKALL,SRMATCH,DIR

 +26       QUIT 

OTHCHK(SRCODE)  NEW OTH,DA,SRY,SRQUIT,SRYBAK,SRXBAK,DIR

 +1        MERGE SRYBAK=Y

 +2        SET SRQUIT=0

           SET SRXBAK=X

 +3        IF 'SRKALL

               WRITE !

               Begin DoDot:1

 +4                IF $$OTLOOP(1)=0

                       QUIT 

 +5                SET DIR(0)="Y"

                   SET DIR("A",1)="The OTHER Prodecure Associations may no longer be correct."

 +6                IF SRCODE

                       Begin DoDot:2

 +7                        IF $PIECE(XQY0,U)'="SROVER"&($PIECE(XQY0,U)'="SRCODING EDIT")

                               SET DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu"

 +8                        SET DIR("A")="Delete OTHER Procedure Associations for this DX"

                           SET DIR("B")="NO"

 +9                        IF $$GET1^DIQ(130.18,D0_","_SRTN_",",3)

                               SET DIR("B")="YES"

 +10                       DO ^DIR

                           WRITE !!

                       End DoDot:2

               End DoDot:1

 +11       IF Y!SRKALL

               Begin DoDot:1

 +12               NEW DA

                   SET OTH=0

 +13               FOR 

                       SET OTH=$ORDER(^SRF(SRTN,13,OTH))

                       IF 'OTH

                           QUIT 

                       Begin DoDot:2

 +14                       SET DA=0

 +15                       FOR 

                               SET DA=$ORDER(^SRF(SRTN,13,OTH,"OADX",DA))

                               IF '+DA

                                   QUIT 

                               Begin DoDot:3

 +16                               IF D0=^SRF(SRTN,13,OTH,"OADX",DA,0)

                                       Begin DoDot:4

 +17                                       DO KOADX(SRTN,OTH)

                                       End DoDot:4

                                       QUIT 

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +18       MERGE Y=SRYBAK

           SET X=SRXBAK

 +19       QUIT 

MSG        IF $DATA(SRFLG)

               QUIT 

 +1        IF '$DATA(EMILY)

               QUIT 

 +2        DO SRCMSG^SROADX1

 +3        DO SRCWRT^SROADX1

 +4        QUIT 

PRLOOP(SRCHK)  NEW SRDX,SRMATCH

           SET (SRDX,SRMATCH)=0

 +1        FOR SRI=1:1

               SET SRDX=$ORDER(^SRF(SRTN,"PADX",SRDX))

               IF 'SRDX

                   QUIT 

               Begin DoDot:1

 +2                IF (D0=^SRF(SRTN,"PADX",SRDX,0))!($GET(DA)=^SRF(SRTN,"PADX",SRDX,0))

                       SET SRMATCH=1

                       QUIT 

               End DoDot:1

 +3        IF SRMATCH

               IF 'SRCHK

                   DO KPADX(SRTN)

 +4        QUIT SRMATCH

OTLOOP(SRCHK)  NEW SRDA,OTH,SRMATCH

           SET (OTH,SRMATCH)=0

 +1        FOR 

               SET OTH=$ORDER(^SRF(SRTN,13,OTH))

               IF 'OTH

                   QUIT 

               Begin DoDot:1

 +2                SET SRDA=0

 +3                FOR 

                       SET SRDA=$ORDER(^SRF(SRTN,13,OTH,"OADX",SRDA))

                       IF '+SRDA

                           QUIT 

                       Begin DoDot:2

 +4                        IF (D0=^SRF(SRTN,13,OTH,"OADX",SRDA,0))!($GET(DA)=^SRF(SRTN,13,OTH,"OADX",SRDA,0))

                               Begin DoDot:3

 +5                                IF 'SRCHK

                                       DO KOADX(SRTN,SRDA)

 +6                                SET SRMATCH=1

                               End DoDot:3

                               QUIT 

                       End DoDot:2

               End DoDot:1

 +7        QUIT SRMATCH

DELASOC    NEW DIR,Y,SRPR,SROT,SRXBAK

 +1        IF '$DATA(SRTN)&$DATA(DA(1))

               SET SRTN=DA(1)

 +2        IF '$DATA(SRTN)&'$DATA(DA(1))

               SET SRTN=DA

 +3        IF $DATA(^TMP($JOB,"SRASOC",SRTN))

               KILL ^TMP($JOB,"SRASOC",SRTN)

               QUIT 

 +4        IF $GET(D0)=""

               QUIT 

 +5        SET SRPR=$$PRLOOP(1)

           SET SROT=$$OTLOOP(1)

           SET SRXBAK=X

 +6        IF 'SRPR

               IF 'SROT

                   QUIT 

 +7        SET DIR(0)="FO"

           SET DIR("A")="Procedure Associations for this Diagnosis will be deleted. Continue"

 +8        DO ^DIR

 +9        SET SRPR=$$PRLOOP(0)

           SET SROT=$$OTLOOP(0)

 +10       SET X=SRXBAK

 +11       QUIT 

PRINASO(SRCODE)  IF $GET(SRTN)=""!($GET(X)="")

               QUIT 

 +1        NEW D0

           SET D0=0

           DO PDXCHK(SRCODE)

           KILL SRCODE

           QUIT 

PRINASOD   IF $GET(SRTN)=""!($GET(X)="")

               QUIT 

 +1        IF $DATA(^TMP($JOB,"SRASOC",SRTN))

               KILL ^TMP($JOB,"SRASOC",SRTN)

               QUIT 

 +2        NEW D0

           SET D0=0

           DO DELASOC

           QUIT 

PCPTASO(SRCODE)  IF $GET(SRTN)=""!($GET(X)="")

               QUIT 

 +1        IF $GET(D0)=""!('+$GET(X)&(SRCODE))!('$DATA(^SRF(SRTN,"PADX")))

               QUIT 

 +2        IF $$EDITWARN(SRCODE)

               DO KPADX(SRTN)

 +3        KILL SRCODE

 +4        QUIT 

OCPTASO(SRCODE)  IF $GET(SRTN)=""!($GET(DA)="")!($GET(X)="")

               QUIT 

 +1        IF $GET(D0)=""!('+$GET(X)&(SRCODE))!('$DATA(^SRF(SRTN,13,DA,"OADX",0)))

               QUIT 

 +2        IF $$EDITWARN(SRCODE)

               DO KOADX(SRTN,DA)

 +3        KILL SRCODE

 +4        QUIT 

EDITWARN(SRCODE)  NEW SRYBAK,SRXBAK,DIR,SRY

 +1        MERGE SRYBAK=Y,SRDABAK=DA

 +2        SET DIR(0)="Y"

           SET DIR("B")="NO"

           SET SRXBAK=X

           SET SRQUIT=0

 +3        SET DIR("A",1)="The Diagnosis to Procedure Associations may no longer be correct."

 +4        IF SRCODE

               Begin DoDot:1

 +5                IF $PIECE(XQY0,U)'="SROVER"&($PIECE(XQY0,U)'="SRCODING EDIT")

                       SET DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu."

 +6                SET DIR("A")="Delete Diagnosis Associations for this Procedure"

 +7                DO ^DIR

               End DoDot:1

 +8        IF 'SRCODE

               Begin DoDot:1

 +9                SET DIR("A")="All DX Associations for this Procedure will be deleted. Continue"

 +10               DO ^DIR

 +11               IF 'Y

                       SET SRXBAK=SRYBAK

               End DoDot:1

 +12       SET X=SRXBAK

           SET SRY=Y

 +13       MERGE Y=SRYBAK,DA=SRDABAK

 +14       WRITE !!

 +15       QUIT SRY

KPADX(SRCN) ; kill all the principal cpt associated diagnosis codes

 +1        NEW DA,DIK,SRX1,Y,SRXBAK

 +2        SET SRX1=0

           SET DA(1)=SRCN

           SET SRXBAK=X

 +3        FOR 

               SET SRX1=$ORDER(^SRF(DA(1),"PADX",SRX1))

               IF 'SRX1

                   QUIT 

               Begin DoDot:1

 +4                SET DA=SRX1

                   SET DA(1)=SRCN

                   SET DIK="^SRF("_DA(1)_",""PADX"","

                   DO ^DIK

               End DoDot:1

 +5        SET X=SRXBAK

 +6        QUIT 

KOADX(SRCN,SRREC) ; kill other cpt associated diagnosis codes

 +1        NEW DA,DIK,SRX1,Y,SRXBAK

 +2        SET SRX1=0

           SET DA(2)=SRCN

           SET SRXBAK=X

 +3        FOR 

               SET SRX1=$ORDER(^SRF(DA(2),13,SRREC,"OADX",SRX1))

               IF 'SRX1

                   QUIT 

               Begin DoDot:1

 +4                SET DA=SRX1

                   SET DA(1)=SRREC

                   SET DA(2)=SRCN

                   SET DIK="^SRF("_DA(2)_",13,"_DA(1)_",""OADX"","

                   DO ^DIK

               End DoDot:1

 +5        SET X=SRXBAK

 +6        QUIT 

ADXCHK    ; check the validity of associations and remove if diagnosis missing

 +1        NEW SRDX,SRX,SRY,SRZ

 +2        SET SRDX=0

 +3        IF $DATA(^SRF(SRTN,13))

               SET SRX=0

               Begin DoDot:1

 +4                FOR 

                       SET SRX=$ORDER(^SRF(SRTN,13,SRX))

                       IF 'SRX

                           QUIT 

                       Begin DoDot:2

 +5                        IF $DATA(^SRF(SRTN,13,SRX,"OADX"))

                               SET SRY=0

                               Begin DoDot:3

 +6                                FOR 

                                       SET SRY=$ORDER(^SRF(SRTN,13,SRX,"OADX",SRY))

                                       IF 'SRY

                                           QUIT 

                                       Begin DoDot:4

 +7                                        SET SRDX=^SRF(SRTN,13,SRX,"OADX",SRY,0)

 +8                                        IF (SRDX'=0)

                                               IF '$DATA(^SRF(SRTN,15,SRDX,0))

                                                   DO KOADX(SRTN,SRX)

 +9                                        IF (SRDX=0)

                                               IF ($PIECE($GET(^SRF(SRTN,34)),U)="")

                                                   IF ('$PIECE($GET(^SRF(SRTN,34)),U,2))

                                                       DO KOADX(SRTN,SRX)

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +10       IF $DATA(^SRF(SRTN,"PADX"))

               SET SRX=0

               Begin DoDot:1

 +11               FOR 

                       SET SRX=$ORDER(^SRF(SRTN,"PADX",SRX))

                       IF 'SRX

                           QUIT 

                       Begin DoDot:2

 +12                       SET SRDX=^SRF(SRTN,"PADX",SRX,0)

 +13                       IF (SRDX'=0)

                               IF '$DATA(^SRF(SRTN,15,SRDX,0))

                                   DO KPADX(SRTN)

                       End DoDot:2

               End DoDot:1

 +14       IF $ORDER(^SRF(SRTN,"PADX",0))

               IF (($PIECE($GET(^SRF(SRTN,34)),U)="")&('$PIECE($GET(^SRF(SRTN,34)),U,2)))!(($PIECE($GET(^SRF(SRTN,"OP")),U)="")&('$PIECE($GET(^SRF(SRTN,"OP")),U,2)))

                   DO KPADX(SRTN)

 +15       QUIT