source: FOIAVistA/tag/r/SURGERY-SR/SROMOD.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.3 KB
Line 
1SROMOD ;BIR/ADM - CPT Modifier Input ; [ 02/27/01 6:32 AM ]
2 ;;3.0; Surgery ;**88,100,127**;24 Jun 93
3 Q
4DISPLAY ; display name with modifier
5 N SRY,SRDA,SRDATE S SRDATE=DT
6 S SRDA=$S($G(SRTN):SRTN,$D(DA(1)):DA(1),$D(DA):DA,1:"")
7 I $G(SRDA) S SRDATE=$P($G(^SRF(SRDA,0)),"^",9)
8 S SRY=$$MOD^ICPTMOD(Y,"I",SRDATE) Q:$P(SRY,"^")=-1
9 S Y=$P(SRY,"^",2)_" "_$P(SRY,"^",3)
10 Q
11SCR27() ; screen for acceptable CPT code/modifier pair for principal procedure
12 N SRCODE,SRDA,SRCMOD,SROK,SRSDATE,SRZ D PCHK K SRM
13 Q SROK
14PCHK ; return value of modifier if acceptable for principal procedure
15 N SRSDATE S SRSDATE=DT K ICPTVDT
16 S SROK=0,SRCODE="",SRDA=$S($G(SRTN):SRTN,$D(DA(1)):DA(1),$D(DA):DA,1:""),SRM=$S($D(SRM):SRM,1:+Y)
17 I SRDA S SRSDATE=$P(^SRF(SRDA,0),"^",9),SRCODE=$P($G(^SRF(SRDA,"OP")),"^",2)
18 I 'SRCODE Q
19 S SRZ=$P($$MODP^ICPTMOD(SRCODE,SRM,"I",SRSDATE),"^") I SRZ>0 S SROK=SRZ
20 S ICPTVDT=SRSDATE
21 Q
22OTH() ; screen for acceptable CPT code/modifier pair for other procedure
23 N SRCODE,SRDA,SRCMOD,SROK,SROTH,SRSDATE,SRZ D OCHK K SRM
24 Q SROK
25OCHK ; return value of modifier if acceptable for other procedure
26 N SRSDATE S SRSDATE=DT K ICPTVDT
27 S SROK=0,SRCODE="",SRDA=$S($G(SRTN):SRTN,$D(DA(2)):DA(2),$D(DA(1)):DA(1),$D(D0):D0,1:""),SROTH=$S($D(DA):DA,$D(D1):D1,1:""),SRM=$S($D(SRM):SRM,1:+Y)
28 I SRDA&SROTH S SRSDATE=$P(^SRF(SRDA,0),"^",9),SRCODE=$P($G(^SRF(SRDA,13,SROTH,2)),"^")
29 I 'SRCODE Q
30 S SRZ=$P($$MODP^ICPTMOD(SRCODE,SRM,"I",SRSDATE),"^") I SRZ>0 S SROK=SRZ
31 S ICPTVDT=SRSDATE
32 Q
33SPRIN ; set logic for ACPT x-ref
34 Q:$E($G(IOST))'="C"!($G(DIK)'="")
35 N SRCODE,SRDA,SRDEF,SRIEN,SRJ,SRQ,SRSDATE,SRSEL,SRSOUT,SRX,SRY,Z S (SRQ,SRSOUT)=0,SRCODE=X N X I $D(SRCMOD) D HYPH27
36 S SRDA=DA,SRIEN=$O(^SRF(SRDA,"OPMOD","AAA"),-1) I SRIEN S SRX=$P(^SRF(SRDA,"OPMOD",SRIEN,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRX,"I"),"^",2)
37 K DIR F D K SRM,SRCMOD Q:SRSOUT S SRQ=0
38 .S DIR("A")=" Modifier: ",DIR(0)="130.028,.01AO" S:$G(SRCMOD)'="" DIR("B")=SRCMOD D:$O(^SRF(SRDA,"OPMOD",0)) QUES
39 .D ^DIR K DIR S DA=SRDA I $D(DTOUT)!$D(DUOUT)!(X="") S SRSOUT=1 Q
40 .I +Y S SRJ=0 F S SRJ=$O(^SRF(SRDA,"OPMOD",SRJ)) Q:'SRJ I $P(^SRF(SRDA,"OPMOD",SRJ,0),"^")=+Y N DIR D Q
41 ..S SRSEL=Y(0),DIR(0)="130.028,.01AO",DIR("A")=" Modifier: ",DIR("B")=$P(Y(0),"^")
42 ..D ^DIR S DA=SRDA I $D(DTOUT)!$D(DUOUT)!(X="") S SRSOUT=1 Q
43 ..I +Y S SRK=0 F S SRK=$O(^SRF(SRDA,"OPMOD",SRK)) Q:'SRK I $P(^SRF(SRDA,"OPMOD",SRK,0),"^")=+Y S SRQ=1 Q
44 ..Q:SRQ I +Y S $P(^SRF(SRDA,"OPMOD",SRJ,0),"^")=+Y,SRQ=1 Q
45 ..I X="@" S SRY(130.028,SRJ_","_SRDA_",",.01)="@" D FILE^DIE("","SRY"),EN^DDIOL(" ... Modifier deleted","","?20") S SRQ=1
46 .Q:SRQ!SRSOUT
47 .I +Y S SRY(130.028,"+1,"_DA_",",.01)=+Y D UPDATE^DIE("","SRY") Q
48 .I X="@",$D(SRCMOD) S SRY(130.028,SRIEN_","_SRDA_",",.01)="@" D FILE^DIE("","SRY"),EN^DDIOL(" ... Modifier deleted","","?20")
49 Q
50KPRIN ; kill logic for ACPT x-ref
51 Q:$E($G(IOST))'="C"!($G(DIK)'="") K ^SRF(DA,"OPMOD")
52 Q
53SOTH ; set logic for ACPT1 x-ref
54 Q:$E($G(IOST))'="C"!($G(DIK)'="")
55 N SRCODE,SRDA,SRDEF,SRIEN,SRJ,SRQ,SRSDATE,SRSEL,SRSOUT,SRX,SRY,Z S (SRQ,SRSOUT)=0,SRCODE=X N X I $D(SRCMOD) D HYPHOTH
56 S SRDA=DA,SRDA(1)=DA(1),SRIEN=$O(^SRF(SRDA(1),13,SRDA,"MOD","A"),-1) I SRIEN S SRX=$P(^SRF(SRDA(1),13,SRDA,"MOD",SRIEN,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRX,"I"),"^",2)
57 K DIR F D K SRM,SRCMOD Q:SRSOUT S SRQ=0
58 .S DIR("A")=" Modifier: ",DIR(0)="130.164,.01AO" S:$G(SRCMOD)'="" DIR("B")=SRCMOD D:$O(^SRF(SRDA(1),13,SRDA,"MOD",0)) QUES1
59 .D ^DIR K DIR S DA=SRDA,DA(1)=SRDA(1) I $D(DTOUT)!$D(DUOUT)!(X="") S SRSOUT=1 Q
60 .I +Y S SRJ=0 F S SRJ=$O(^SRF(SRDA(1),13,SRDA,"MOD",SRJ)) Q:'SRJ I $P(^SRF(SRDA(1),13,SRDA,"MOD",SRJ,0),"^")=+Y N DIR D Q
61 ..S SRSEL=Y(0),DIR(0)="130.164,.01AO",DIR("A")=" Modifier: ",DIR("B")=$P(Y(0),"^")
62 ..D ^DIR S DA=SRDA I $D(DTOUT)!$D(DUOUT)!(X="") S SRSOUT=1 Q
63 ..I +Y S SRK=0 F S SRK=$O(^SRF(SRDA(1),13,SRDA,"MOD",SRK)) Q:'SRK I $P(^SRF(SRDA(1),13,SRDA,"MOD",SRK,0),"^")=+Y S Y="" Q
64 ..I X="@" S SRY(130.164,SRJ_","_SRDA_","_SRDA(1)_",",.01)="@" D FILE^DIE("","SRY"),EN^DDIOL(" ... Modifier deleted","","?20") S SRQ=1
65 .Q:SRQ!SRSOUT
66 .I +Y S SRY(130.164,"+1,"_DA_","_DA(1)_",",.01)=+Y D UPDATE^DIE("","SRY") Q
67 .I X="@",$D(SRCMOD) S SRY(130.164,SRIEN_","_SRDA_",",SRDA(1)_",",.01)="@" D FILE^DIE("","SRY"),EN^DDIOL(" ... Modifier deleted","","?20")
68 Q
69KOTH ; kill logic for ACPT1 x-ref
70 Q:$E($G(IOST))'="C"!($G(DIK)'="") K ^SRF(DA(1),13,DA,"MOD")
71 Q
72HYPH27 ; input CPT hyphenated modifier for principal procedure
73 N SRCODE,SRDA,SRDUP,SRLIST,SRN,SROK,SRY S SRLIST=SRCMOD
74 F SRN=1:1 S SRCMOD=$P(SRLIST,",",SRN) Q:SRCMOD="" D
75 .S (SRDUP,SROK)=0
76 .S SRM=$P($$MOD^ICPTMOD(SRCMOD),"^") K:SRM<0 SRM I $D(SRM) D PCHK K SRM
77 .I 'SROK D EN^DDIOL("CPT Modifier '"_SRCMOD_"' is not acceptable with this CPT code.","","!") K SRCMOD Q
78 .S SRJ=0 F S SRJ=$O(^SRF(SRDA,"OPMOD",SRJ)) Q:'SRJ I $P(^SRF(SRDA,"OPMOD",SRJ,0),"^")=SROK S SRDUP=1 Q
79 .I 'SRDUP S SRY(130.028,"+1,"_DA_",",.01)=SROK D UPDATE^DIE("","SRY")
80 Q
81HYPHOTH ; input CPT hyphenated modifier for other procedure
82 N SRCODE,SRDA,SRDUP,SRLIST,SRN,SROK,SROTH,SRY S SRLIST=SRCMOD
83 F SRN=1:1 S SRCMOD=$P(SRLIST,",",SRN) Q:SRCMOD="" D
84 .S (SRDUP,SROK)=0
85 .S SRM=$P($$MOD^ICPTMOD(SRCMOD),"^") K:SRM<0 SRM I $D(SRM) D OCHK K SRM
86 .I 'SROK D EN^DDIOL("CPT Modifier '"_SRCMOD_"' is not acceptable with this CPT code.","","!") K SRCMOD Q
87 .S SRJ=0 F S SRJ=$O(^SRF(SRDA,13,SROTH,"MOD",SRJ)) Q:'SRJ I $P(^SRF(SRDA,13,SROTH,"MOD",SRJ,0),"^")=SROK S SRDUP=1 Q
88 .I 'SRDUP S SRY(130.164,"+1,"_DA_","_DA(1)_",",.01)=SROK D UPDATE^DIE("","SRY")
89 Q
90QUES N SRI,SRMD,SRX,SRY,SRZ S DIR("?",1)=" Answer with PRIN. PROCEDURE CPT MODIFIER",DIR("?",2)="Choose from:"
91 S SRI=0,SRCT=3 F S SRI=$O(^SRF(SRDA,"OPMOD",SRI)) Q:'SRI S SRMD=$P(^SRF(SRDA,"OPMOD",SRI,0),"^") D
92 .S SRX=$$MOD^ICPTMOD(SRMD,"I",$P($G(^SRF(SRDA,0)),"^",9)),SRY=$P(SRX,"^",2),SRZ=$P(SRX,"^",3)
93 .S DIR("?",SRCT)=" "_SRY_" "_SRZ,SRCT=SRCT+1
94 S DIR("?",SRCT)="",DIR("?")=" You may enter a new PRIN. PROCEDURE CPT MODIFIER, if you wish."
95 Q
96QUES1 N SRI,SRMD,SRX,SRY,SRZ S DIR("?",1)=" Answer with OTHER PROCEDURE CPT MODIFIER",DIR("?",2)="Choose from:"
97 S SRI=0,SRCT=3 F S SRI=$O(^SRF(SRDA(1),13,SRDA,"MOD",SRI)) Q:'SRI S SRMD=$P(^SRF(SRDA(1),13,SRDA,"MOD",SRI,0),"^") D
98 .S SRX=$$MOD^ICPTMOD(SRMD,"I",$P($G(^SRF(SRDA,0)),"^",9)),SRY=$P(SRX,"^",2),SRZ=$P(SRX,"^",3)
99 .S DIR("?",SRCT)=" "_SRY_" "_SRZ,SRCT=SRCT+1
100 S DIR("?",SRCT)="",DIR("?")=" You may enter a new OTHER PROCEDURE CPT MODIFIER, if you wish."
101 Q
102
Note: See TracBrowser for help on using the repository browser.