SROADX1 ;BIR/RJS - CONTINUED FROM SROADX ASSOCIATED DIAGNOSIS FOR CODER AND VERIFY SCREENS ;09/12/05 12:01pm
;;3.0;Surgery;**119,150,177**;24 Jun 93;Build 89
OTHADX ;Display ASDX for OTHER PROCS
K SRTMP,SRASSD,SROICD
S SRPADX=0,SROCNTR=1
F SRI=1:1 S SRPADX=$O(^SRF(SRTN,13,OTH,"OADX",SRPADX)) Q:'SRPADX D
.S SRASSD=^SRF(SRTN,13,OTH,"OADX",SRPADX,0)
.D AASDX
.S SRTMP(SRI)=SROICD,SROCNTR=SROCNTR+1
S SROCNTR=0
D ADXDISP
I '$O(^SRF(SRTN,13,OTH,"OADX",0)) W !,?5,SRMSG,!
D PASSDIAG
D ASSDIAG
Q
ASDX N SRI,SRFIRST,SRICD9,SRPRIN,SRPADX,SRASSD ;Display ASDX for PRIN Procs
K SRTMP
S SRI=0,SRFIRST=1
F S SRI=$O(^SRF(SRTN,"OPMOD",SRI)) Q:'SRI S SRM=$P(^SRF(SRTN,"OPMOD",SRI,0),U)
S SRPADX=0,SROCNTR=2
F SRI=1:1 S SRPADX=$O(^SRF(SRTN,"PADX",SRPADX)) Q:'SRPADX D
.S SRASSD=^SRF(SRTN,"PADX",SRPADX,0)
.D AASDX
.S SRTMP(SRI)=SROICD,SROCNTR=SROCNTR+1
D ADXDISP
I '$O(^SRF(SRTN,"PADX",0)) W !,?5,SRMSG
D PASSDIAG
D ASSDIAG
Q
AASDX S SROICD=""
S:SRASSD SRICD9=$P($G(^SRF(SRTN,15,SRASSD,0)),U,3)
S:'SRASSD SRICD9=$P($G(^SRF(SRTN,34)),U,2)
S:SRICD9 SROICD=$$ICDSTR
I 'SRICD9 D
.S:SRASSD SROICD=$P($G(^SRF(SRTN,15,SRASSD,0)),U)
.S:'SRASSD SROICD=$P($G(^SRF(SRTN,34)),U,1)
Q
PASSDIAG N ADCNT,SRICD9,SRFLG,SRCNTR,SRASSD ;List PRIN DX to assoc.
K SRADX,SRDIRX,SRADIAG
S SRICD9=$P($G(^SRF(SRTN,34)),U,2)
I SRICD9'="" S SRDIRX(1)=$$ICDSTR,SRADX(1)=$P(SRDIRX(1),U,2),SRADIAG(1)=0
I SRICD9="" S SRDIRX(1)=$P($G(^SRF(SRTN,34)),U,1),SRADIAG(1)=0
Q
ASSDIAG N SRDCNT,SRADCNT,SRQ ;DXs for assoc.
S (ADCNT,SRASSD)=0,SRCNT=2
F S ADCNT=$O(^SRF(SRTN,15,ADCNT)) Q:ADCNT="" D
.S SRICD9=$P(^SRF(SRTN,15,ADCNT,0),U,3)
.S:SRICD9'="" SRDIRX(SRCNT)=$$ICDSTR,SRADX(SRCNT)=$P(SRDIRX(SRCNT),U,2)
.S:SRICD9="" SRDIRX(SRCNT)=$P(^SRF(SRTN,15,ADCNT,0),U,1)
.S SRADIAG(SRCNT)=ADCNT,SRCNT=SRCNT+1
S SRDX2="LO^:0"
I (ADCNT<$$SRDIAGS) D
.S:(SRCNT>2) SRDIRX(SRCNT)="ALL"
.S:$D(SRDIRX) SRDX2="LO^:"_SRCNT
.S:$$SRDIAGS=1 SRDX2="LO^:"_(SRCNT-1)
Q
SRDIAGS() N SRDIAGS,SRDGCNT
S (SRDIAGS,SRDGCNT)=0
S:($P($G(^SRF(SRTN,34)),U)'="")!($P($G(^SRF(SRTN,34)),U,2)) SRDIAGS=1
F I=1:1 S SRDGCNT=$O(^SRF(SRTN,15,SRDGCNT)) Q:SRDGCNT="" S SRDIAGS=SRDIAGS+1
Q SRDIAGS
ICDSTR() N SRICDSTR
S SRICDSTR=$$ICD^SROICD(SRTN,SRICD9),SRICDSTR=$P(SRICDSTR,U,2)_"-"_$P(SRICDSTR,U,4)
Q SRICDSTR
PASSDS() N SRPADX,SRASSDS,SRPX
S SRASSDS="",SRPADX=0
F SRI=1:1 S SRPADX=$O(^SRF(SRTN,"PADX",SRPADX)) Q:'SRPADX D
.S SRPX=^SRF(SRTN,"PADX",SRPADX,0)
.S SRPX=SRPX+1
.S SRASSDS=$S($L(SRASSDS)<1:SRPX,1:SRASSDS_","_SRPX)
Q SRASSDS
OASSDS() N SRPADX,SRASSDS,SRPX
S SRASSDS="",SRPADX=0
F SRI=1:1 S SRPADX=$O(^SRF(SRTN,13,D0,"OADX",SRPADX)) Q:'SRPADX D
.S SRPX=^SRF(SRTN,13,D0,"OADX",SRPADX,0)
.S SRPX=SRPX+1
.S SRASSDS=$S($L(SRASSDS)<1:SRPX,1:SRASSDS_","_SRPX)
Q SRASSDS
SRODIR N SRFLG,SRCNT,SRCNTR
S DIR("A",1)=""
S (SRFLG,SRCNT)=1,SRCNTR=2,ADCNT=""
F S ADCNT=$O(SRDIRX(ADCNT)) Q:'ADCNT D
.S:'$D(DIR("A",SRCNTR)) DIR("A",SRCNTR)=""
.S DIR("A",SRCNTR)=DIR("A",SRCNTR)_SRCNT_". "_SRDIRX(ADCNT),SRCNT=SRCNT+1,SRCNTR=SRCNTR+1,SRFLG=1
S DIR("A",SRCNTR+2)=SRODIR("A",1),DIR("A")=SRODIR("A"),DIR("A",SRCNTR+1)=""
Q
COTHBLD N SRCNT,OTH,X,CPT,CPT1,SRDA K SRSEL
S OTH=0,SRCNT=1
F S OTH=$O(^SRF(SRTN,13,OTH)) Q:'OTH D
.S OTHER=$P(^SRF(SRTN,13,OTH,0),U)
.S X=$P($G(^SRF(SRTN,13,OTH,2)),U),CPT="NOT ENTERED",CPT1=""
.I X S CPT1=X,Y=$$CPT^ICPTCOD(X),SRCPT=$P(Y,U,2),SRSHT=$P(Y,U,3),Y=SRCPT,SRDA=OTH D SSOTH^SROCPT S SRCPT=Y,CPT=SRCPT_" "_SRSHT
.S SRSEL(SRCNT)=OTH_U_OTHER_"^CPT Code: "_CPT_U_CPT1
.S SRCNT=SRCNT+1
Q
OTHADXD N SRCOMMA,SROADX,SRICD9,SROADX1,SROODX,SRASSD,SRSUB ;OTHER PROCS ADXs
I '$O(^SRF(SRTN,13,OTH,"OADX",0)) W !,?5,SRMSG Q
S SRSUB=1
D OTHADX
Q
PADXD N SRCOMMA,SRPADX,SRICD9,SRPDX,SRPDX1,SROPRIN,SRSUB
S SRPADX=0,SROCNTR=2,SRSUB=1
D ADXCHK^SROADX2
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
.S SRASSD=0,SRFDA="130.275",SRIENU="+1"_","_SRTN_",",SRIENF=0_","_SRTN_"," D UPDATE,FILE
D ASDX
Q
ADXDISP N SROCNTR ;ADXS for PROC
W !,?5,"Assoc. DX"_$$ICDSTR^SROICD(SRTN)_": "
S (SROCNTR,SRDXCNT)=0
F I=1:1 S SROCNTR=$O(SRTMP(SROCNTR)) Q:'SROCNTR D
.I $D(SRSUB) D
..W:'(I#2) ?48
..W:I#2 ?16
..W I,". ",$E(SRTMP(SROCNTR),1,25)
..I '(I#2),($O(SRTMP(SROCNTR))) W !
.W:'$D(SRSUB) !,?8,I,". ",SRTMP(SROCNTR)
S SRDXCNT=I
S SRDX1="LO^:"_SRDXCNT
S:SRDXCNT>0 SRDX1="LO^:"_SRDXCNT
Q
OTHCPTD N SRM,SRI,SRFIRST ;PROCS/Codes/Mods.
S SRFIRST=0
W !,?3,"Other Procedures:",!!,OTHCNT,"."
D COTHBLD
W ?3,$P(SRSEL(SRDA),U,2),!,?2,"Other ",$P(SRSEL(SRDA),U,3)
S OTH=$P(SRSEL(SRDA),U) K SRDES S CPT1=$P(SRSEL(SRDA),U,4),X=$$CPTD^ICPTCOD(CPT1,"SRDES") I $O(SRDES(0)) F I=1:1:X W !,?4,SRDES(I)
W !,?3,"Modifiers: "
S SRI=0
F S SRI=$O(^SRF(SRTN,13,OTH,"MOD",SRI)) Q:'SRI D
.S SRM=$P(^SRF(SRTN,13,OTH,"MOD",SRI,0),U)
.W:SRFIRST !,?14
.W $P($$MOD^ICPTMOD(SRM,"I"),"^",2),"-",$P($$MOD^ICPTMOD(SRM,"I"),"^",3)
.S SRFIRST=1
Q
CPTDISP S X=$P(^SRF(SRTN,"OP"),U,2) I X D W !
.S SRY=$$CPT^ICPTCOD(X),Y=$P(SRY,U,2),(SROCPT2,Z)=$P(SRY,U,3)
S:'$D(Y) Y="NOT ENTERED",Z=""
W " CPT Code: "_Y_" ",Z,!," Description:" D ^SROCPT W ! F I=1:1:80 W "-"
W !,?3,"Principal CPT Code: "_Y_" ",!,?3,"Description:",Z,!,?3,"Modifiers: "
S SRMOD=0
F S SRMOD=$O(^SRF(SRTN,"OPMOD",SRMOD)) Q:'SRMOD D
.S SRMO=$P(^SRF(SRTN,"OPMOD",SRMOD,0),U)
.W:$G(SRFIRST) !,?14
.W $P($$MOD^ICPTMOD(SRMO,"I"),"^",2),"-",$P($$MOD^ICPTMOD(SRMO,"I"),"^",3)
.S SRFIRST=1
Q
PADDALL Q:$E($G(IOST))'="C"!($G(DIK)'="")
D KPADX^SROADX2(DA)
N DIE,DR,DA,PADX,SRY,SRY1,SRICD9,SRCNTRN,SRIENU,SRIENF,SRASSD
S SRY(0)=Y(0),SRFDA="130.275",SRIENU="+1"_","_SRTN_","
S SRICD9=$P($G(^SRF(SRTN,34)),U,2),SRCNTR=1,SRIENF=SRCNTR_","_SRTN_",",SRASSD=0
K SRY1 D UPDATE,FILE
S PADX=0
F S PADX=$O(^SRF(SRTN,15,PADX)) Q:'PADX S SRASSD=PADX,SRICD9=$P(^SRF(SRTN,15,SRASSD,0),U,3),SRCNTR=SRCNTR+1,SRIENF=SRCNTR_","_SRTN_"," K SRY1 D UPDATE,FILE
S Y(0)=SRY(0)
Q
PADD1 ;PRIN ADX
N SRY,SRY0,SRY1,SRY2,SRC,REC,DIE,DA,DR,SRASSD
S SRY(0)=Y(0)
D KPADX^SROADX2(SRTN)
S SRCNTR=0,SRASSD=SRADIAG($P(SRY(0),",",1)),SRFDA="130.275",SRIENU="+1"_","_SRTN_",",SRIENF=SRCNTR_","_SRTN_"," D UPDATE,FILE
S SRY(0)=$E(SRY(0),2,$L(SRY(0)))
F SRY2=1:1:$P(SRDX2,":",2) D
.S SRY0=$P(SRY(0),",",SRY2)
.Q:SRY0<1
.S SRCNTR=$P(^SRF(SRTN,"PADX",0),U,3)+1,SRASSD=SRADIAG(SRY0),SRFDA="130.275",SRIENU="+1"_","_SRTN_",",SRIENF=SRCNTR_","_SRTN_"," D UPDATE,FILE
S Y(0)=SRY(0)
Q
UPDATE ;
S SRY1(SRFDA,SRIENU,".01")=SRASSD
D UPDATE^DIE("","SRY1")
Q
FILE ;
S SRY1(SRFDA,SRIENF,".01")=SRASSD
D FILE^DIE("","SRY1")
K SRY1
Q
PDELALL W !,"Are you sure you want to DELETE ALL Associated Diagnoses ? (Y/N) "
S SRY(0)=Y(0)
S %=2 D YN^DICN
I %=1 Q:$E($G(IOST))'="C"!($G(DIK)'="") D KPADX^SROADX2(DA)
S Y(0)=SRY(0)
Q
PDEL1 N SRC,SRY,SRY1,SRY2,REC,SRICD9,SRASSD ;DEL 1 PRIN ADX
S (SRY,SRY0)=0
F S SRY=$O(^SRF(SRTN,"PADX",SRY)) Q:'SRY S SRY0=SRY0+1,REC(SRY0)=SRY
S SRY(0)=Y(0),SRFDA="130.275"
F SRY2=1:1:SRDXCNT D
.S SRY0=$P(SRY(0),",",SRY2)
.Q:'SRY0
.Q:'$D(REC(SRY0))
.I SRY0=1,$P(^SRF(SRTN,"PADX",0),U,4)>1 K SRC S SRC(1)="PLEASE DELETE ALL DIAGNOSIS BEFORE THE PRINCIPAL",SRC(1,"F")="!!?5" D SRCWRT K SRC Q
.S SRIENF=REC(SRY0)_","_SRTN_",",SRASSD="@"
.W !,"Are you sure you want to DELETE ",SRTMP(SRY0)," ? (Y/N) "
.S %=2 D YN^DICN
.I %=1 D FILE
S Y(0)=SRY(0)
Q
ODEL1 N SRY,SRY0,SRY1,SRY2,SRASSD ;DEL 1 OTH ADX
S (SRY,SRY0)=0
F S SRY=$O(^SRF(SRTN,13,OTH,"OADX",SRY)) Q:'SRY S SRY0=SRY0+1,REC(SRY0)=SRY
S SRY(0)=Y(0),SRFDA="130.165"
F SRY2=1:1:SRDXCNT D
.S SRY0=$P(SRY(0),",",SRY2)
.Q:'SRY0
.S SRIENF=REC(SRY0)_","_OTH_","_SRTN_",",SRASSD="@"
.W !,"Are you sure you want to DELETE ",SRTMP(SRY0)," ? (Y/N) "
.Q:SRTMP(SRY0)=""
.S %=2 D YN^DICN
.I %=1 D FILE
S Y(0)=SRY(0)
Q
OADDALL Q:$E($G(IOST))'="C"!($G(DIK)'="") D KOADX^SROADX2(SRTN,OTH) ;Associate all Diagnosis to OTHER Procedure
N SRICD9,PADX,SRFDA,SRIENU,SRIENF,SRY,SRY1
S SRY(0)=Y(0),SRFDA="130.165",SRIENU="+1"_","_OTH_","_SRTN_","
S PADX=0
F S PADX=$O(SRADIAG(PADX)) Q:'PADX S SRASSD=SRADIAG(PADX),SRIENF=PADX_","_OTH_","_SRTN_"," K SRY1 D UPDATE,FILE
S Y(0)=SRY(0)
Q
OADD1 N SRY,SRY0,SRY1,SRY2,SRCNTR,SRASSD ;Associate 1 Diagnosis to OTHER Procedure
S SRY(0)=Y(0),SRCNTR=0
S:$D(^SRF(SRTN,13,OTH,"OADX")) SRCNTR=$P(^SRF(SRTN,13,OTH,"OADX",0),U,3)+1
D KOADX^SROADX2(SRTN,OTH)
S:'$D(^SRF(SRTN,13,OTH,"OADX")) SRCNTR=1
S SRFDA="130.165",SRIENU="+1"_","_OTH_","_SRTN_","
I SRDIRX(+Y)="ALL" D
.S SRY0=0
.F S SRY0=$O(SRADIAG(SRY0)) Q:'SRY0 D
..I '$D(^SRF(SRTN,13,OTH,"OADX","B",SRADIAG(SRY0))) D
..S SRASSD=SRADIAG(SRY0),SRIENF=SRCNTR_","_OTH_","_SRTN_"," K SRY1 D UPDATE,FILE
..S SRCNTR=SRCNTR+1
I SRDIRX(+Y)'="ALL" D
.F SRY2=1:1:$P(SRDX2,":",2) D
..S SRY0=$P(SRY(0),",",SRY2)
..Q:'SRY0
..S SRASSD=SRADIAG(SRY0),SRIENF=SRCNTR_","_OTH_","_SRTN_"," K SRY1 D UPDATE,FILE
..S SRCNTR=SRCNTR+1
S Y(0)=SRY(0)
Q
SRCMSG S SRDX=X
S SRC(1)="The Diagnosis/Procedure Code Association may no longer be correct,",SRC(1,"F")="!!?5"
S SRC(2)="please confirm or update the values in the Diagnosis Association Field",SRC(2,"F")="!?5"
Q
SRCWRT D EN^DDIOL(.SRC)
D CONT
Q:$G(DTOUT)
S:$D(SRDX) X=SRDX
S SRFLG=1
Q
CONT N DIR
S DIR(0)="FO^"
S DIR("A")="Press RETURN to continue "
D ^DIR
Q
ADXKILL K ADCNT,SRCOMMA,SRDXCNT,SROCNTR,SROCPT2,SROFLG,SRTMP,SRICD9,SRDIAGS
K SRASDX,SRMSG,SRADX,SRPADX,SRODIR,REC,SRDIRX,SROANS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROADX1 9639 printed Sep 11, 2024@03:00:14 Page 2
SROADX1 ;BIR/RJS - CONTINUED FROM SROADX ASSOCIATED DIAGNOSIS FOR CODER AND VERIFY SCREENS ;09/12/05 12:01pm
+1 ;;3.0;Surgery;**119,150,177**;24 Jun 93;Build 89
OTHADX ;Display ASDX for OTHER PROCS
+1 KILL SRTMP,SRASSD,SROICD
+2 SET SRPADX=0
SET SROCNTR=1
+3 FOR SRI=1:1
SET SRPADX=$ORDER(^SRF(SRTN,13,OTH,"OADX",SRPADX))
if 'SRPADX
QUIT
Begin DoDot:1
+4 SET SRASSD=^SRF(SRTN,13,OTH,"OADX",SRPADX,0)
+5 DO AASDX
+6 SET SRTMP(SRI)=SROICD
SET SROCNTR=SROCNTR+1
End DoDot:1
+7 SET SROCNTR=0
+8 DO ADXDISP
+9 IF '$ORDER(^SRF(SRTN,13,OTH,"OADX",0))
WRITE !,?5,SRMSG,!
+10 DO PASSDIAG
+11 DO ASSDIAG
+12 QUIT
ASDX ;Display ASDX for PRIN Procs
NEW SRI,SRFIRST,SRICD9,SRPRIN,SRPADX,SRASSD
+1 KILL SRTMP
+2 SET SRI=0
SET SRFIRST=1
+3 FOR
SET SRI=$ORDER(^SRF(SRTN,"OPMOD",SRI))
if 'SRI
QUIT
SET SRM=$PIECE(^SRF(SRTN,"OPMOD",SRI,0),U)
+4 SET SRPADX=0
SET SROCNTR=2
+5 FOR SRI=1:1
SET SRPADX=$ORDER(^SRF(SRTN,"PADX",SRPADX))
if 'SRPADX
QUIT
Begin DoDot:1
+6 SET SRASSD=^SRF(SRTN,"PADX",SRPADX,0)
+7 DO AASDX
+8 SET SRTMP(SRI)=SROICD
SET SROCNTR=SROCNTR+1
End DoDot:1
+9 DO ADXDISP
+10 IF '$ORDER(^SRF(SRTN,"PADX",0))
WRITE !,?5,SRMSG
+11 DO PASSDIAG
+12 DO ASSDIAG
+13 QUIT
AASDX SET SROICD=""
+1 if SRASSD
SET SRICD9=$PIECE($GET(^SRF(SRTN,15,SRASSD,0)),U,3)
+2 if 'SRASSD
SET SRICD9=$PIECE($GET(^SRF(SRTN,34)),U,2)
+3 if SRICD9
SET SROICD=$$ICDSTR
+4 IF 'SRICD9
Begin DoDot:1
+5 if SRASSD
SET SROICD=$PIECE($GET(^SRF(SRTN,15,SRASSD,0)),U)
+6 if 'SRASSD
SET SROICD=$PIECE($GET(^SRF(SRTN,34)),U,1)
End DoDot:1
+7 QUIT
PASSDIAG ;List PRIN DX to assoc.
NEW ADCNT,SRICD9,SRFLG,SRCNTR,SRASSD
+1 KILL SRADX,SRDIRX,SRADIAG
+2 SET SRICD9=$PIECE($GET(^SRF(SRTN,34)),U,2)
+3 IF SRICD9'=""
SET SRDIRX(1)=$$ICDSTR
SET SRADX(1)=$PIECE(SRDIRX(1),U,2)
SET SRADIAG(1)=0
+4 IF SRICD9=""
SET SRDIRX(1)=$PIECE($GET(^SRF(SRTN,34)),U,1)
SET SRADIAG(1)=0
+5 QUIT
ASSDIAG ;DXs for assoc.
NEW SRDCNT,SRADCNT,SRQ
+1 SET (ADCNT,SRASSD)=0
SET SRCNT=2
+2 FOR
SET ADCNT=$ORDER(^SRF(SRTN,15,ADCNT))
if ADCNT=""
QUIT
Begin DoDot:1
+3 SET SRICD9=$PIECE(^SRF(SRTN,15,ADCNT,0),U,3)
+4 if SRICD9'=""
SET SRDIRX(SRCNT)=$$ICDSTR
SET SRADX(SRCNT)=$PIECE(SRDIRX(SRCNT),U,2)
+5 if SRICD9=""
SET SRDIRX(SRCNT)=$PIECE(^SRF(SRTN,15,ADCNT,0),U,1)
+6 SET SRADIAG(SRCNT)=ADCNT
SET SRCNT=SRCNT+1
End DoDot:1
+7 SET SRDX2="LO^:0"
+8 IF (ADCNT<$$SRDIAGS)
Begin DoDot:1
+9 if (SRCNT>2)
SET SRDIRX(SRCNT)="ALL"
+10 if $DATA(SRDIRX)
SET SRDX2="LO^:"_SRCNT
+11 if $$SRDIAGS=1
SET SRDX2="LO^:"_(SRCNT-1)
End DoDot:1
+12 QUIT
SRDIAGS() NEW SRDIAGS,SRDGCNT
+1 SET (SRDIAGS,SRDGCNT)=0
+2 if ($PIECE($GET(^SRF(SRTN,34)),U)'="")!($PIECE($GET(^SRF(SRTN,34)),U,2))
SET SRDIAGS=1
+3 FOR I=1:1
SET SRDGCNT=$ORDER(^SRF(SRTN,15,SRDGCNT))
if SRDGCNT=""
QUIT
SET SRDIAGS=SRDIAGS+1
+4 QUIT SRDIAGS
ICDSTR() NEW SRICDSTR
+1 SET SRICDSTR=$$ICD^SROICD(SRTN,SRICD9)
SET SRICDSTR=$PIECE(SRICDSTR,U,2)_"-"_$PIECE(SRICDSTR,U,4)
+2 QUIT SRICDSTR
PASSDS() NEW SRPADX,SRASSDS,SRPX
+1 SET SRASSDS=""
SET SRPADX=0
+2 FOR SRI=1:1
SET SRPADX=$ORDER(^SRF(SRTN,"PADX",SRPADX))
if 'SRPADX
QUIT
Begin DoDot:1
+3 SET SRPX=^SRF(SRTN,"PADX",SRPADX,0)
+4 SET SRPX=SRPX+1
+5 SET SRASSDS=$SELECT($LENGTH(SRASSDS)<1:SRPX,1:SRASSDS_","_SRPX)
End DoDot:1
+6 QUIT SRASSDS
OASSDS() NEW SRPADX,SRASSDS,SRPX
+1 SET SRASSDS=""
SET SRPADX=0
+2 FOR SRI=1:1
SET SRPADX=$ORDER(^SRF(SRTN,13,D0,"OADX",SRPADX))
if 'SRPADX
QUIT
Begin DoDot:1
+3 SET SRPX=^SRF(SRTN,13,D0,"OADX",SRPADX,0)
+4 SET SRPX=SRPX+1
+5 SET SRASSDS=$SELECT($LENGTH(SRASSDS)<1:SRPX,1:SRASSDS_","_SRPX)
End DoDot:1
+6 QUIT SRASSDS
SRODIR NEW SRFLG,SRCNT,SRCNTR
+1 SET DIR("A",1)=""
+2 SET (SRFLG,SRCNT)=1
SET SRCNTR=2
SET ADCNT=""
+3 FOR
SET ADCNT=$ORDER(SRDIRX(ADCNT))
if 'ADCNT
QUIT
Begin DoDot:1
+4 if '$DATA(DIR("A",SRCNTR))
SET DIR("A",SRCNTR)=""
+5 SET DIR("A",SRCNTR)=DIR("A",SRCNTR)_SRCNT_". "_SRDIRX(ADCNT)
SET SRCNT=SRCNT+1
SET SRCNTR=SRCNTR+1
SET SRFLG=1
End DoDot:1
+6 SET DIR("A",SRCNTR+2)=SRODIR("A",1)
SET DIR("A")=SRODIR("A")
SET DIR("A",SRCNTR+1)=""
+7 QUIT
COTHBLD NEW SRCNT,OTH,X,CPT,CPT1,SRDA
KILL SRSEL
+1 SET OTH=0
SET SRCNT=1
+2 FOR
SET OTH=$ORDER(^SRF(SRTN,13,OTH))
if 'OTH
QUIT
Begin DoDot:1
+3 SET OTHER=$PIECE(^SRF(SRTN,13,OTH,0),U)
+4 SET X=$PIECE($GET(^SRF(SRTN,13,OTH,2)),U)
SET CPT="NOT ENTERED"
SET CPT1=""
+5 IF X
SET CPT1=X
SET Y=$$CPT^ICPTCOD(X)
SET SRCPT=$PIECE(Y,U,2)
SET SRSHT=$PIECE(Y,U,3)
SET Y=SRCPT
SET SRDA=OTH
DO SSOTH^SROCPT
SET SRCPT=Y
SET CPT=SRCPT_" "_SRSHT
+6 SET SRSEL(SRCNT)=OTH_U_OTHER_"^CPT Code: "_CPT_U_CPT1
+7 SET SRCNT=SRCNT+1
End DoDot:1
+8 QUIT
OTHADXD ;OTHER PROCS ADXs
NEW SRCOMMA,SROADX,SRICD9,SROADX1,SROODX,SRASSD,SRSUB
+1 IF '$ORDER(^SRF(SRTN,13,OTH,"OADX",0))
WRITE !,?5,SRMSG
QUIT
+2 SET SRSUB=1
+3 DO OTHADX
+4 QUIT
PADXD NEW SRCOMMA,SRPADX,SRICD9,SRPDX,SRPDX1,SROPRIN,SRSUB
+1 SET SRPADX=0
SET SROCNTR=2
SET SRSUB=1
+2 DO ADXCHK^SROADX2
+3 IF '$ORDER(^SRF(SRTN,"PADX",0))
IF (($PIECE($GET(^SRF(SRTN,34)),U)'="")!($PIECE($GET(^SRF(SRTN,34)),U,2)))
IF (($PIECE($GET(^SRF(SRTN,"OP")),U)'="")!($PIECE($GET(^SRF(SRTN,"OP")),U,2)))
Begin DoDot:1
+4 SET SRASSD=0
SET SRFDA="130.275"
SET SRIENU="+1"_","_SRTN_","
SET SRIENF=0_","_SRTN_","
DO UPDATE
DO FILE
End DoDot:1
+5 DO ASDX
+6 QUIT
ADXDISP ;ADXS for PROC
NEW SROCNTR
+1 WRITE !,?5,"Assoc. DX"_$$ICDSTR^SROICD(SRTN)_": "
+2 SET (SROCNTR,SRDXCNT)=0
+3 FOR I=1:1
SET SROCNTR=$ORDER(SRTMP(SROCNTR))
if 'SROCNTR
QUIT
Begin DoDot:1
+4 IF $DATA(SRSUB)
Begin DoDot:2
+5 if '(I#2)
WRITE ?48
+6 if I#2
WRITE ?16
+7 WRITE I,". ",$EXTRACT(SRTMP(SROCNTR),1,25)
+8 IF '(I#2)
IF ($ORDER(SRTMP(SROCNTR)))
WRITE !
End DoDot:2
+9 if '$DATA(SRSUB)
WRITE !,?8,I,". ",SRTMP(SROCNTR)
End DoDot:1
+10 SET SRDXCNT=I
+11 SET SRDX1="LO^:"_SRDXCNT
+12 if SRDXCNT>0
SET SRDX1="LO^:"_SRDXCNT
+13 QUIT
OTHCPTD ;PROCS/Codes/Mods.
NEW SRM,SRI,SRFIRST
+1 SET SRFIRST=0
+2 WRITE !,?3,"Other Procedures:",!!,OTHCNT,"."
+3 DO COTHBLD
+4 WRITE ?3,$PIECE(SRSEL(SRDA),U,2),!,?2,"Other ",$PIECE(SRSEL(SRDA),U,3)
+5 SET OTH=$PIECE(SRSEL(SRDA),U)
KILL SRDES
SET CPT1=$PIECE(SRSEL(SRDA),U,4)
SET X=$$CPTD^ICPTCOD(CPT1,"SRDES")
IF $ORDER(SRDES(0))
FOR I=1:1:X
WRITE !,?4,SRDES(I)
+6 WRITE !,?3,"Modifiers: "
+7 SET SRI=0
+8 FOR
SET SRI=$ORDER(^SRF(SRTN,13,OTH,"MOD",SRI))
if 'SRI
QUIT
Begin DoDot:1
+9 SET SRM=$PIECE(^SRF(SRTN,13,OTH,"MOD",SRI,0),U)
+10 if SRFIRST
WRITE !,?14
+11 WRITE $PIECE($$MOD^ICPTMOD(SRM,"I"),"^",2),"-",$PIECE($$MOD^ICPTMOD(SRM,"I"),"^",3)
+12 SET SRFIRST=1
End DoDot:1
+13 QUIT
CPTDISP SET X=$PIECE(^SRF(SRTN,"OP"),U,2)
IF X
Begin DoDot:1
+1 SET SRY=$$CPT^ICPTCOD(X)
SET Y=$PIECE(SRY,U,2)
SET (SROCPT2,Z)=$PIECE(SRY,U,3)
End DoDot:1
WRITE !
+2 if '$DATA(Y)
SET Y="NOT ENTERED"
SET Z=""
+3 WRITE " CPT Code: "_Y_" ",Z,!," Description:"
DO ^SROCPT
WRITE !
FOR I=1:1:80
WRITE "-"
+4 WRITE !,?3,"Principal CPT Code: "_Y_" ",!,?3,"Description:",Z,!,?3,"Modifiers: "
+5 SET SRMOD=0
+6 FOR
SET SRMOD=$ORDER(^SRF(SRTN,"OPMOD",SRMOD))
if 'SRMOD
QUIT
Begin DoDot:1
+7 SET SRMO=$PIECE(^SRF(SRTN,"OPMOD",SRMOD,0),U)
+8 if $GET(SRFIRST)
WRITE !,?14
+9 WRITE $PIECE($$MOD^ICPTMOD(SRMO,"I"),"^",2),"-",$PIECE($$MOD^ICPTMOD(SRMO,"I"),"^",3)
+10 SET SRFIRST=1
End DoDot:1
+11 QUIT
PADDALL if $EXTRACT($GET(IOST))'="C"!($GET(DIK)'="")
QUIT
+1 DO KPADX^SROADX2(DA)
+2 NEW DIE,DR,DA,PADX,SRY,SRY1,SRICD9,SRCNTRN,SRIENU,SRIENF,SRASSD
+3 SET SRY(0)=Y(0)
SET SRFDA="130.275"
SET SRIENU="+1"_","_SRTN_","
+4 SET SRICD9=$PIECE($GET(^SRF(SRTN,34)),U,2)
SET SRCNTR=1
SET SRIENF=SRCNTR_","_SRTN_","
SET SRASSD=0
+5 KILL SRY1
DO UPDATE
DO FILE
+6 SET PADX=0
+7 FOR
SET PADX=$ORDER(^SRF(SRTN,15,PADX))
if 'PADX
QUIT
SET SRASSD=PADX
SET SRICD9=$PIECE(^SRF(SRTN,15,SRASSD,0),U,3)
SET SRCNTR=SRCNTR+1
SET SRIENF=SRCNTR_","_SRTN_","
KILL SRY1
DO UPDATE
DO FILE
+8 SET Y(0)=SRY(0)
+9 QUIT
PADD1 ;PRIN ADX
+1 NEW SRY,SRY0,SRY1,SRY2,SRC,REC,DIE,DA,DR,SRASSD
+2 SET SRY(0)=Y(0)
+3 DO KPADX^SROADX2(SRTN)
+4 SET SRCNTR=0
SET SRASSD=SRADIAG($PIECE(SRY(0),",",1))
SET SRFDA="130.275"
SET SRIENU="+1"_","_SRTN_","
SET SRIENF=SRCNTR_","_SRTN_","
DO UPDATE
DO FILE
+5 SET SRY(0)=$EXTRACT(SRY(0),2,$LENGTH(SRY(0)))
+6 FOR SRY2=1:1:$PIECE(SRDX2,":",2)
Begin DoDot:1
+7 SET SRY0=$PIECE(SRY(0),",",SRY2)
+8 if SRY0<1
QUIT
+9 SET SRCNTR=$PIECE(^SRF(SRTN,"PADX",0),U,3)+1
SET SRASSD=SRADIAG(SRY0)
SET SRFDA="130.275"
SET SRIENU="+1"_","_SRTN_","
SET SRIENF=SRCNTR_","_SRTN_","
DO UPDATE
DO FILE
End DoDot:1
+10 SET Y(0)=SRY(0)
+11 QUIT
UPDATE ;
+1 SET SRY1(SRFDA,SRIENU,".01")=SRASSD
+2 DO UPDATE^DIE("","SRY1")
+3 QUIT
FILE ;
+1 SET SRY1(SRFDA,SRIENF,".01")=SRASSD
+2 DO FILE^DIE("","SRY1")
+3 KILL SRY1
+4 QUIT
PDELALL WRITE !,"Are you sure you want to DELETE ALL Associated Diagnoses ? (Y/N) "
+1 SET SRY(0)=Y(0)
+2 SET %=2
DO YN^DICN
+3 IF %=1
if $EXTRACT($GET(IOST))'="C"!($GET(DIK)'="")
QUIT
DO KPADX^SROADX2(DA)
+4 SET Y(0)=SRY(0)
+5 QUIT
PDEL1 ;DEL 1 PRIN ADX
NEW SRC,SRY,SRY1,SRY2,REC,SRICD9,SRASSD
+1 SET (SRY,SRY0)=0
+2 FOR
SET SRY=$ORDER(^SRF(SRTN,"PADX",SRY))
if 'SRY
QUIT
SET SRY0=SRY0+1
SET REC(SRY0)=SRY
+3 SET SRY(0)=Y(0)
SET SRFDA="130.275"
+4 FOR SRY2=1:1:SRDXCNT
Begin DoDot:1
+5 SET SRY0=$PIECE(SRY(0),",",SRY2)
+6 if 'SRY0
QUIT
+7 if '$DATA(REC(SRY0))
QUIT
+8 IF SRY0=1
IF $PIECE(^SRF(SRTN,"PADX",0),U,4)>1
KILL SRC
SET SRC(1)="PLEASE DELETE ALL DIAGNOSIS BEFORE THE PRINCIPAL"
SET SRC(1,"F")="!!?5"
DO SRCWRT
KILL SRC
QUIT
+9 SET SRIENF=REC(SRY0)_","_SRTN_","
SET SRASSD="@"
+10 WRITE !,"Are you sure you want to DELETE ",SRTMP(SRY0)," ? (Y/N) "
+11 SET %=2
DO YN^DICN
+12 IF %=1
DO FILE
End DoDot:1
+13 SET Y(0)=SRY(0)
+14 QUIT
ODEL1 ;DEL 1 OTH ADX
NEW SRY,SRY0,SRY1,SRY2,SRASSD
+1 SET (SRY,SRY0)=0
+2 FOR
SET SRY=$ORDER(^SRF(SRTN,13,OTH,"OADX",SRY))
if 'SRY
QUIT
SET SRY0=SRY0+1
SET REC(SRY0)=SRY
+3 SET SRY(0)=Y(0)
SET SRFDA="130.165"
+4 FOR SRY2=1:1:SRDXCNT
Begin DoDot:1
+5 SET SRY0=$PIECE(SRY(0),",",SRY2)
+6 if 'SRY0
QUIT
+7 SET SRIENF=REC(SRY0)_","_OTH_","_SRTN_","
SET SRASSD="@"
+8 WRITE !,"Are you sure you want to DELETE ",SRTMP(SRY0)," ? (Y/N) "
+9 if SRTMP(SRY0)=""
QUIT
+10 SET %=2
DO YN^DICN
+11 IF %=1
DO FILE
End DoDot:1
+12 SET Y(0)=SRY(0)
+13 QUIT
OADDALL ;Associate all Diagnosis to OTHER Procedure
if $EXTRACT($GET(IOST))'="C"!($GET(DIK)'="")
QUIT
DO KOADX^SROADX2(SRTN,OTH)
+1 NEW SRICD9,PADX,SRFDA,SRIENU,SRIENF,SRY,SRY1
+2 SET SRY(0)=Y(0)
SET SRFDA="130.165"
SET SRIENU="+1"_","_OTH_","_SRTN_","
+3 SET PADX=0
+4 FOR
SET PADX=$ORDER(SRADIAG(PADX))
if 'PADX
QUIT
SET SRASSD=SRADIAG(PADX)
SET SRIENF=PADX_","_OTH_","_SRTN_","
KILL SRY1
DO UPDATE
DO FILE
+5 SET Y(0)=SRY(0)
+6 QUIT
OADD1 ;Associate 1 Diagnosis to OTHER Procedure
NEW SRY,SRY0,SRY1,SRY2,SRCNTR,SRASSD
+1 SET SRY(0)=Y(0)
SET SRCNTR=0
+2 if $DATA(^SRF(SRTN,13,OTH,"OADX"))
SET SRCNTR=$PIECE(^SRF(SRTN,13,OTH,"OADX",0),U,3)+1
+3 DO KOADX^SROADX2(SRTN,OTH)
+4 if '$DATA(^SRF(SRTN,13,OTH,"OADX"))
SET SRCNTR=1
+5 SET SRFDA="130.165"
SET SRIENU="+1"_","_OTH_","_SRTN_","
+6 IF SRDIRX(+Y)="ALL"
Begin DoDot:1
+7 SET SRY0=0
+8 FOR
SET SRY0=$ORDER(SRADIAG(SRY0))
if 'SRY0
QUIT
Begin DoDot:2
+9 IF '$DATA(^SRF(SRTN,13,OTH,"OADX","B",SRADIAG(SRY0)))
Begin DoDot:3
End DoDot:3
+10 SET SRASSD=SRADIAG(SRY0)
SET SRIENF=SRCNTR_","_OTH_","_SRTN_","
KILL SRY1
DO UPDATE
DO FILE
+11 SET SRCNTR=SRCNTR+1
End DoDot:2
End DoDot:1
+12 IF SRDIRX(+Y)'="ALL"
Begin DoDot:1
+13 FOR SRY2=1:1:$PIECE(SRDX2,":",2)
Begin DoDot:2
+14 SET SRY0=$PIECE(SRY(0),",",SRY2)
+15 if 'SRY0
QUIT
+16 SET SRASSD=SRADIAG(SRY0)
SET SRIENF=SRCNTR_","_OTH_","_SRTN_","
KILL SRY1
DO UPDATE
DO FILE
+17 SET SRCNTR=SRCNTR+1
End DoDot:2
End DoDot:1
+18 SET Y(0)=SRY(0)
+19 QUIT
SRCMSG SET SRDX=X
+1 SET SRC(1)="The Diagnosis/Procedure Code Association may no longer be correct,"
SET SRC(1,"F")="!!?5"
+2 SET SRC(2)="please confirm or update the values in the Diagnosis Association Field"
SET SRC(2,"F")="!?5"
+3 QUIT
SRCWRT DO EN^DDIOL(.SRC)
+1 DO CONT
+2 if $GET(DTOUT)
QUIT
+3 if $DATA(SRDX)
SET X=SRDX
+4 SET SRFLG=1
+5 QUIT
CONT NEW DIR
+1 SET DIR(0)="FO^"
+2 SET DIR("A")="Press RETURN to continue "
+3 DO ^DIR
+4 QUIT
ADXKILL KILL ADCNT,SRCOMMA,SRDXCNT,SROCNTR,SROCPT2,SROFLG,SRTMP,SRICD9,SRDIAGS
+1 KILL SRASDX,SRMSG,SRADX,SRPADX,SRODIR,REC,SRDIRX,SROANS
+2 QUIT
