source: WorldVistAEHR/trunk/r/SURGERY-SR/SROCDX.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1SROCDX ;BIR/ADM - CASE CODING INPUT/EDIT ;08/29/05
2 ;;3.0; Surgery ;**142**;24 Jun 93
3PCPT ; edit principal procedure code
4 N SRPPY,SRPRIN S (SRPRIN,X)=$P(^SRO(136,SRTN,0),"^",2) I 'X D PPROC Q
5 W !,"Principal Procedure:",! D CPTDISP,ASDX^SROCDX1
6 K DIR S DIR(0)="SO^1:Update Principal Procedure CPT Code;2:Update Associated Diagnoses"
7 S DIR("A")="Enter selection (1 or 2)",DIR("B")=1 D ^DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
8 S SRPPY=Y D Q
9 .I SRPPY=1 D PPROC Q
10 .I SRPPY=2 D CASDX
11 Q
12PPROC N SRCPT S SRCPT=$P(^SRO(136,SRTN,0),"^",2),SRDIE=1 W !
13 K DR,DIE,DA S DIE=136,DA=SRTN,DR=".02T" D ^DIE K DIE,DR,SRDIE I $D(Y) S SRSOUT=1
14 D PRIN^SROMOD0 I SRCPT'=$P(^SRO(136,SRTN,0),"^",2) D SADXP^SROCDX2 K DA
15 S X=$P(^SRO(136,SRTN,0),"^",2) I $G(SRPRIN)=X Q
16CASDX ; associate principal CPT to diagnosis
17 N SRADX,SRDX0,SRDX1,SRDX2,SRDXCT,SRODIR,SRDIRX,OTHCNT,SRASSDS,SROCT
18 S CPT=$P(^SRO(136,SRTN,0),"^",2) Q:'CPT K DIR
19 S SRODIR("A",1)=" Select the number(s) of the Diagnosis Code to associate to"
20 S SRODIR("A")=" the procedure selected"
21 D HDR^SROCD,CPTDISP,ASDX^SROCDX1
22 K DIR D SRODIR
23 W !
24 S DIR(0)=SRDX2,SRASSDS=$$PASSDS^SROCDX1,DIR("B")=SRASSDS
25 F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
26 Q:(Y["^")!(Y="")
27 D PADD1^SROCDX1 Q
28 Q:Y="Q"!(Y["")
29 G CASDX
30 Q
31COTHADX D COTHBLD ;Associate "Other" CPTs to Diagnosis
32 N SRDX0,SRDX1,SRDX2,SRDIR,OTHCNT,SRASSDS
33 S OTHCNT=SRDA
34 S SRODIR("A",1)=" Select the number(s) of the Diagnosis Code to associate to"
35 S SRODIR("A")=" the procedure selected"
36 K DIR D HDR^SROCD,OTHCPTD,OTHADX^SROCDX1
37 K DIR D SRODIR W ! F I=1:1:80 W "-"
38 S DIR(0)=SRDX2 I $G(D0)="",$G(SRPOTH) S D0=SRPOTH
39 S SRASSDS=$$OASSDS^SROCDX1
40 S DIR("B")=SRASSDS I SRASSDS="",$G(SRDIRX(1))'="" S DIR("B")=1
41 F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
42 Q:(Y["^")!(Y="")
43 D OADD1^SROCDX1
44 Q:Y="Q"!(Y["")
45 G COTHADX
46 Q
47DXDUP(SRDX) I (Y["^")!($G(DTOUT)) Q 0
48 N SRAI,SRDXX,SRDUP,DIR S SRDUP=0
49 I SRDX="" Q 0
50 F SRAI=1:1:$L(SRDX,",") D
51 .Q:$P(SRDX,",",SRAI)<1
52 .I $D(SRDXX($P(SRDX,",",SRAI)))!((SRDIRX($P(SRDX,",",SRAI))="ALL")&($L(SRDX,",")>1)) S SRDUP=1,DIR(0)="FO^",DIR("A",1)=" **Duplicates entered",DIR("A")=" Press Return to continue" D ^DIR
53 .S SRDXX($P(SRDX,",",SRAI))=""
54 Q SRDUP
55VALASC() I (Y["^")!('$G(Y(0)))!($G(DTOUT)) Q 1
56 N VALA,DIR S VALA=1
57 S:Y=""!(Y=U)!('+Y(0))!(Y[",0")!($P(Y,",",1)=0) VALA=0
58 I 'VALA S DIR("A",1)=" **Invalid input",DIR(0)="FO^",DIR("A")=" Press Return to continue" D ^DIR
59 Q VALA
60SRODIR N SRFLG,SRCNT,SRCNTR
61 S DIR("A",1)="Only the following ICD Diagnosis Codes can be associated:"
62 S DIR("A",2)=""
63 S (SRFLG,SRCNT)=1,SRCNTR=3,ADCNT="" F S ADCNT=$O(SRDIRX(ADCNT)) Q:'ADCNT D
64 .S:'$D(DIR("A",SRCNTR)) DIR("A",SRCNTR)=""
65 .S DIR("A",SRCNTR)=DIR("A",SRCNTR)_SRCNT_". "_SRDIRX(ADCNT),SRCNT=SRCNT+1,SRCNTR=SRCNTR+1,SRFLG=1
66 S DIR("A",SRCNTR+2)=SRODIR("A",1),DIR("A")=SRODIR("A"),DIR("A",SRCNTR+1)=""
67 Q
68COTHBLD N SRCNT,OTH,X,CPT,CPT1,SRDA K SRSEL
69 S OTH=0,SRCNT=1 F S OTH=$O(^SRO(136,SRTN,3,OTH)) Q:'OTH D
70 .S X=$P(^SRO(136,SRTN,3,OTH,0),U),CPT1=""
71 .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^SROCPT0 S SRCPT=Y,CPT=SRCPT_" "_SRSHT
72 .S SRSEL(SRCNT)=OTH_"^CPT Code: "_CPT_U_CPT1_U_$E(SRCPT,1,5)_" "_SRSHT
73 .S SRCNT=SRCNT+1
74 Q
75OTHCPTD N SRM,SRI,SRFIRST,SRY ;PROCS/Codes/Mods.
76 S SRFIRST=0 D COTHBLD
77 W !,"Other Procedures:",!!,OTHCNT,"."," CPT Code: "_$P(SRSEL(SRDA),U,4)
78 S OTH=$P(SRSEL(SRDA),U) W !,?5,"Modifiers: "
79 S SRI=0 F S SRI=$O(^SRO(136,SRTN,3,OTH,1,SRI)) Q:'SRI D
80 .S SRM=$P(^SRO(136,SRTN,3,OTH,1,SRI,0),U)
81 .W:SRFIRST !,?16 W $P($$MOD^ICPTMOD(SRM,"I"),"^",2),"-",$P($$MOD^ICPTMOD(SRM,"I"),"^",3)
82 .S SRFIRST=1
83 I '$O(^SRO(136,SRTN,3,OTH,1,0)) W "NOT ENTERED"
84 Q
85CPTDISP N SRFIRST,SRMO
86 S X=$P(^SRO(136,SRTN,0),U,2) I X S SRY=$$CPT^ICPTCOD(X),Y=$P(SRY,U,2),(SROCPT2,Z)=$P(SRY,U,3)
87 S:'$D(Y) Y="NOT ENTERED",Z="" W !,?3,"CPT Code: "_Y_" "_Z,!,?3,"Modifiers: "
88 I '$O(^SRO(136,SRTN,1,0)) W "NOT ENTERED"
89 S SRMOD=0 F S SRMOD=$O(^SRO(136,SRTN,1,SRMOD)) Q:'SRMOD D
90 .S SRMO=$P(^SRO(136,SRTN,1,SRMOD,0),U)
91 .W:$G(SRFIRST) !,?14 W $P($$MOD^ICPTMOD(SRMO,"I"),"^",2),"-",$P($$MOD^ICPTMOD(SRMO,"I"),"^",3)
92 .S SRFIRST=1
93 Q
Note: See TracBrowser for help on using the repository browser.