SROCDX1 ;BIR/ADM,BAJ - ASSOCIATED DIAGNOSIS FOR CODER SCREENS ; 4/17/07 11:04am
;;3.0;Surgery;**142,161,177**;24 Jun 93;Build 89
OTHADX ;Display ASDX for OTHER PROCS
N SRTMP,SRASSD,SROICD
S SRPADX=0,SROCNTR=1 F SRI=1:1 S SRPADX=$O(^SRO(136,SRTN,3,OTH,2,SRPADX)) Q:'SRPADX D
.S SRICD9=^SRO(136,SRTN,3,OTH,2,SRPADX,0)
.S:SRICD9 SROICD=$$ICDSTR
.S SRTMP(SRI)=SROICD,SROCNTR=SROCNTR+1
S SROCNTR=0
D ADXDISP I '$O(^SRO(136,SRTN,3,OTH,2,0)) W "NOT ENTERED",!
D PASSDIAG,ASSDIAG
Q
ASDX ;Display ASDX for PRIN Procs
N SRI,SRFIRST,SRICD9,SRPRIN,SRPADX,SRASSD K SRTMP
S SRI=0,SRFIRST=1 F S SRI=$O(^SRO(136,SRTN,1,SRI)) Q:'SRI S SRM=$P(^SRO(136,SRTN,1,SRI,0),U)
S SRPADX=0,SROCNTR=2 F SRI=1:1 S SRPADX=$O(^SRO(136,SRTN,2,SRPADX)) Q:'SRPADX D
.S SRICD9=^SRO(136,SRTN,2,SRPADX,0) Q:'SRICD9
.S:SRICD9 SROICD=$$ICDSTR
.S SRTMP(SRI)=$G(SROICD),SROCNTR=$G(SROCNTR)+1
D ADXDISP I '$O(^SRO(136,SRTN,2,0)) W !,?5,SRMSG
D PASSDIAG,ASSDIAG
Q
AASDX S SROICD=""
S:SRASSD SRICD9=$P($G(^SRO(136,SRTN,4,SRASSD,0)),U)
S:'SRASSD SRICD9=$P($G(^SRO(136,SRTN,0)),U,3)
S:SRICD9 SROICD=$$ICDSTR
Q
PASSDIAG N ADCNT,SRICD9,SRFLG,SRCNTR,SRASSD ;List PRIN DX to assoc.
K SRADX,SRDIRX,SRADIAG S SRICD9=$P($G(^SRO(136,SRTN,0)),U,3)
I SRICD9'="" S SRDIRX(1)=$$ICDSTR,SRADX(1)=$P(SRDIRX(1),U,2),SRADIAG(1)=$P($G(^SRO(136,SRTN,0)),U,3)
I SRICD9="" S SRDIRX(1)="",SRADIAG(1)=""
Q
ASSDIAG N SRDCNT,SRADCNT,SRQ ;DXs for assoc.
S (ADCNT,SRASSD)=0 S SRCNT=$S($G(SRDIRX(1))'="":1,1:0)
F S ADCNT=$O(^SRO(136,SRTN,4,ADCNT)) Q:ADCNT="" D
.S SRICD9=$P(^SRO(136,SRTN,4,ADCNT,0),U)
.S:SRICD9'="" SRCNT=SRCNT+1,SRDIRX(SRCNT)=$$ICDSTR,SRADX(SRCNT)=$P(SRDIRX(SRCNT),U,2)
.S:SRICD9="" SRDIRX(SRCNT)=$P(^SRO(136,SRTN,4,ADCNT,0),U)
.S SRADIAG(SRCNT)=$P(^SRO(136,SRTN,4,ADCNT,0),U)
;modified to use 1 as lower limit, SRCNT as upper (SRO*3.0*161)
S:$D(SRDIRX) SRDX2="LO^1:"_SRCNT
Q
SRDIAGS() N SRDIAGS,SRDGCNT
S (SRDIAGS,SRDGCNT)=0 S:$D(^SRF(SRTN,34)) 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 SRDX,SRI,SRJ,SRPADX,SRASSDS,SRPX
S SRASSDS="",SRPADX=0 F S SRPADX=$O(^SRO(136,SRTN,2,SRPADX)) Q:'SRPADX D
.S SRDX=$P(^SRO(136,SRTN,2,SRPADX,0),"^")
.S SRJ=0 F S SRJ=$O(SRADIAG(SRJ)) Q:'SRJ I SRADIAG(SRJ)=SRDX S SRPX=SRJ Q
.S SRASSDS=$S($L(SRASSDS)<1:SRPX,1:SRASSDS_","_SRPX)
Q SRASSDS
OASSDS() N SRDX,SRI,SRJ,SRPADX,SRASSDS,SRPX
S SRASSDS="",SRPADX=0 F S SRPADX=$O(^SRO(136,SRTN,3,SRPOTH,2,SRPADX)) Q:'SRPADX D
.S SRDX=$P(^SRO(136,SRTN,3,SRPOTH,2,SRPADX,0),"^")
.S SRJ=0 F S SRJ=$O(SRADIAG(SRJ)) Q:'SRJ I SRADIAG(SRJ)=SRDX S SRPX=SRJ Q
.S SRASSDS=$S($L(SRASSDS)<1:SRPX,1:SRASSDS_","_SRPX)
Q SRASSDS
OTHADXD N SRCOMMA,SROADX,SRICD9,SROADX1,SROODX,SRASSD,SRSUB ;OTHER PROCS ADXs
I '$O(^SRO(136,SRTN,3,OTH,2,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
I '$O(^SRO(136,SRTN,2,0)),$P(^SRO(136,SRTN,0),U,3) D
.S SRASSD=$P(^SRO(136,SRTN,0),U,3),SRFDA="136.02",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)_": " N SRFIRST
S (SROCNTR,SRDXCNT)=0,SRFIRST=1
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 $E(SRTMP(SROCNTR),1,28)
..I '(I#2),($O(SRTMP(SROCNTR))) W !
.I '$D(SRSUB) W:'SRFIRST ! W ?16,$E(SRTMP(SROCNTR),1,28) S SRFIRST=0
S SRDXCNT=I,SRDX1="LO^:"_SRDXCNT S:SRDXCNT>0 SRDX1="LO^:"_SRDXCNT
Q
PADD1 ;PRIN ADX
N SRY,SRY0,SRY1,SRY2,SRC,REC,DIE,DA,DR,SRASSD
S SRY(0)=Y(0)
D KPADX^SROCDX2(SRTN)
S SRCNTR=0,SRASSD=SRADIAG($P(SRY(0),",",1)),SRFDA="136.02",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(^SRO(136,SRTN,2,0),U,3)+1,SRASSD=SRADIAG(SRY0),SRFDA="136.02",SRIENU="+1"_","_SRTN_",",SRIENF=SRCNTR_","_SRTN_"," 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(^SRO(136,SRTN,3,OTH,2)) SRCNTR=$P(^SRO(136,SRTN,3,OTH,2,0),U,3)+1
D KOADX^SROCDX2(SRTN,OTH)
S:'$D(^SRO(136,SRTN,3,OTH,2)) SRCNTR=1
S SRFDA="136.32",SRIENU="+1"_","_OTH_","_SRTN_","
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
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
CONT N DIR S DIR(0)="FO^",DIR("A")="Press RETURN to continue " D ^DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROCDX1 4923 printed Sep 23, 2025@20:19:06 Page 2
SROCDX1 ;BIR/ADM,BAJ - ASSOCIATED DIAGNOSIS FOR CODER SCREENS ; 4/17/07 11:04am
+1 ;;3.0;Surgery;**142,161,177**;24 Jun 93;Build 89
OTHADX ;Display ASDX for OTHER PROCS
+1 NEW SRTMP,SRASSD,SROICD
+2 SET SRPADX=0
SET SROCNTR=1
FOR SRI=1:1
SET SRPADX=$ORDER(^SRO(136,SRTN,3,OTH,2,SRPADX))
if 'SRPADX
QUIT
Begin DoDot:1
+3 SET SRICD9=^SRO(136,SRTN,3,OTH,2,SRPADX,0)
+4 if SRICD9
SET SROICD=$$ICDSTR
+5 SET SRTMP(SRI)=SROICD
SET SROCNTR=SROCNTR+1
End DoDot:1
+6 SET SROCNTR=0
+7 DO ADXDISP
IF '$ORDER(^SRO(136,SRTN,3,OTH,2,0))
WRITE "NOT ENTERED",!
+8 DO PASSDIAG
DO ASSDIAG
+9 QUIT
ASDX ;Display ASDX for PRIN Procs
+1 NEW SRI,SRFIRST,SRICD9,SRPRIN,SRPADX,SRASSD
KILL SRTMP
+2 SET SRI=0
SET SRFIRST=1
FOR
SET SRI=$ORDER(^SRO(136,SRTN,1,SRI))
if 'SRI
QUIT
SET SRM=$PIECE(^SRO(136,SRTN,1,SRI,0),U)
+3 SET SRPADX=0
SET SROCNTR=2
FOR SRI=1:1
SET SRPADX=$ORDER(^SRO(136,SRTN,2,SRPADX))
if 'SRPADX
QUIT
Begin DoDot:1
+4 SET SRICD9=^SRO(136,SRTN,2,SRPADX,0)
if 'SRICD9
QUIT
+5 if SRICD9
SET SROICD=$$ICDSTR
+6 SET SRTMP(SRI)=$GET(SROICD)
SET SROCNTR=$GET(SROCNTR)+1
End DoDot:1
+7 DO ADXDISP
IF '$ORDER(^SRO(136,SRTN,2,0))
WRITE !,?5,SRMSG
+8 DO PASSDIAG
DO ASSDIAG
+9 QUIT
AASDX SET SROICD=""
+1 if SRASSD
SET SRICD9=$PIECE($GET(^SRO(136,SRTN,4,SRASSD,0)),U)
+2 if 'SRASSD
SET SRICD9=$PIECE($GET(^SRO(136,SRTN,0)),U,3)
+3 if SRICD9
SET SROICD=$$ICDSTR
+4 QUIT
PASSDIAG ;List PRIN DX to assoc.
NEW ADCNT,SRICD9,SRFLG,SRCNTR,SRASSD
+1 KILL SRADX,SRDIRX,SRADIAG
SET SRICD9=$PIECE($GET(^SRO(136,SRTN,0)),U,3)
+2 IF SRICD9'=""
SET SRDIRX(1)=$$ICDSTR
SET SRADX(1)=$PIECE(SRDIRX(1),U,2)
SET SRADIAG(1)=$PIECE($GET(^SRO(136,SRTN,0)),U,3)
+3 IF SRICD9=""
SET SRDIRX(1)=""
SET SRADIAG(1)=""
+4 QUIT
ASSDIAG ;DXs for assoc.
NEW SRDCNT,SRADCNT,SRQ
+1 SET (ADCNT,SRASSD)=0
SET SRCNT=$SELECT($GET(SRDIRX(1))'="":1,1:0)
+2 FOR
SET ADCNT=$ORDER(^SRO(136,SRTN,4,ADCNT))
if ADCNT=""
QUIT
Begin DoDot:1
+3 SET SRICD9=$PIECE(^SRO(136,SRTN,4,ADCNT,0),U)
+4 if SRICD9'=""
SET SRCNT=SRCNT+1
SET SRDIRX(SRCNT)=$$ICDSTR
SET SRADX(SRCNT)=$PIECE(SRDIRX(SRCNT),U,2)
+5 if SRICD9=""
SET SRDIRX(SRCNT)=$PIECE(^SRO(136,SRTN,4,ADCNT,0),U)
+6 SET SRADIAG(SRCNT)=$PIECE(^SRO(136,SRTN,4,ADCNT,0),U)
End DoDot:1
+7 ;modified to use 1 as lower limit, SRCNT as upper (SRO*3.0*161)
+8 if $DATA(SRDIRX)
SET SRDX2="LO^1:"_SRCNT
+9 QUIT
SRDIAGS() NEW SRDIAGS,SRDGCNT
+1 SET (SRDIAGS,SRDGCNT)=0
if $DATA(^SRF(SRTN,34))
SET SRDIAGS=1
+2 FOR I=1:1
SET SRDGCNT=$ORDER(^SRF(SRTN,15,SRDGCNT))
if SRDGCNT=""
QUIT
SET SRDIAGS=SRDIAGS+1
+3 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 SRDX,SRI,SRJ,SRPADX,SRASSDS,SRPX
+1 SET SRASSDS=""
SET SRPADX=0
FOR
SET SRPADX=$ORDER(^SRO(136,SRTN,2,SRPADX))
if 'SRPADX
QUIT
Begin DoDot:1
+2 SET SRDX=$PIECE(^SRO(136,SRTN,2,SRPADX,0),"^")
+3 SET SRJ=0
FOR
SET SRJ=$ORDER(SRADIAG(SRJ))
if 'SRJ
QUIT
IF SRADIAG(SRJ)=SRDX
SET SRPX=SRJ
QUIT
+4 SET SRASSDS=$SELECT($LENGTH(SRASSDS)<1:SRPX,1:SRASSDS_","_SRPX)
End DoDot:1
+5 QUIT SRASSDS
OASSDS() NEW SRDX,SRI,SRJ,SRPADX,SRASSDS,SRPX
+1 SET SRASSDS=""
SET SRPADX=0
FOR
SET SRPADX=$ORDER(^SRO(136,SRTN,3,SRPOTH,2,SRPADX))
if 'SRPADX
QUIT
Begin DoDot:1
+2 SET SRDX=$PIECE(^SRO(136,SRTN,3,SRPOTH,2,SRPADX,0),"^")
+3 SET SRJ=0
FOR
SET SRJ=$ORDER(SRADIAG(SRJ))
if 'SRJ
QUIT
IF SRADIAG(SRJ)=SRDX
SET SRPX=SRJ
QUIT
+4 SET SRASSDS=$SELECT($LENGTH(SRASSDS)<1:SRPX,1:SRASSDS_","_SRPX)
End DoDot:1
+5 QUIT SRASSDS
OTHADXD ;OTHER PROCS ADXs
NEW SRCOMMA,SROADX,SRICD9,SROADX1,SROODX,SRASSD,SRSUB
+1 IF '$ORDER(^SRO(136,SRTN,3,OTH,2,0))
WRITE !,?5,SRMSG
QUIT
+2 SET SRSUB=1
DO OTHADX
+3 QUIT
PADXD NEW SRCOMMA,SRPADX,SRICD9,SRPDX,SRPDX1,SROPRIN,SRSUB
+1 SET SRPADX=0
SET SROCNTR=2
SET SRSUB=1
+2 IF '$ORDER(^SRO(136,SRTN,2,0))
IF $PIECE(^SRO(136,SRTN,0),U,3)
Begin DoDot:1
+3 SET SRASSD=$PIECE(^SRO(136,SRTN,0),U,3)
SET SRFDA="136.02"
SET SRIENU="+1"_","_SRTN_","
SET SRIENF=0_","_SRTN_","
DO UPDATE
DO FILE
End DoDot:1
+4 DO ASDX
+5 QUIT
ADXDISP ;ADXS for PROC
NEW SROCNTR
+1 WRITE !,?5,"Assoc. DX"_$$ICDSTR^SROICD(SRTN)_": "
NEW SRFIRST
+2 SET (SROCNTR,SRDXCNT)=0
SET SRFIRST=1
+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
if I#2
WRITE ?16
WRITE $EXTRACT(SRTMP(SROCNTR),1,28)
+6 IF '(I#2)
IF ($ORDER(SRTMP(SROCNTR)))
WRITE !
End DoDot:2
+7 IF '$DATA(SRSUB)
if 'SRFIRST
WRITE !
WRITE ?16,$EXTRACT(SRTMP(SROCNTR),1,28)
SET SRFIRST=0
End DoDot:1
+8 SET SRDXCNT=I
SET SRDX1="LO^:"_SRDXCNT
if SRDXCNT>0
SET SRDX1="LO^:"_SRDXCNT
+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^SROCDX2(SRTN)
+4 SET SRCNTR=0
SET SRASSD=SRADIAG($PIECE(SRY(0),",",1))
SET SRFDA="136.02"
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(^SRO(136,SRTN,2,0),U,3)+1
SET SRASSD=SRADIAG(SRY0)
SET SRFDA="136.02"
SET SRIENU="+1"_","_SRTN_","
SET SRIENF=SRCNTR_","_SRTN_","
DO UPDATE
DO FILE
End DoDot:1
+10 SET Y(0)=SRY(0)
+11 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(^SRO(136,SRTN,3,OTH,2))
SET SRCNTR=$PIECE(^SRO(136,SRTN,3,OTH,2,0),U,3)+1
+3 DO KOADX^SROCDX2(SRTN,OTH)
+4 if '$DATA(^SRO(136,SRTN,3,OTH,2))
SET SRCNTR=1
+5 SET SRFDA="136.32"
SET SRIENU="+1"_","_OTH_","_SRTN_","
+6 FOR SRY2=1:1:$PIECE(SRDX2,":",2)
Begin DoDot:1
+7 SET SRY0=$PIECE(SRY(0),",",SRY2)
+8 if 'SRY0
QUIT
+9 SET SRASSD=SRADIAG(SRY0)
SET SRIENF=SRCNTR_","_OTH_","_SRTN_","
KILL SRY1
DO UPDATE
DO FILE
+10 SET SRCNTR=SRCNTR+1
End DoDot:1
+11 SET Y(0)=SRY(0)
+12 QUIT
UPDATE ;
+1 SET SRY1(SRFDA,SRIENU,".01")=SRASSD
+2 DO UPDATE^DIE("","SRY1")
+3 QUIT
FILE ;
+1 SET SRY1(SRFDA,SRIENF,".01")=SRASSD
DO FILE^DIE("","SRY1")
KILL SRY1
+2 QUIT
CONT NEW DIR
SET DIR(0)="FO^"
SET DIR("A")="Press RETURN to continue "
DO ^DIR
+1 QUIT
