- 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 Feb 19, 2025@00:06:56 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