source: WorldVistAEHR/trunk/r/SURGERY-SR/SROCPT0.m@ 1006

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

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1SROCPT0 ;BIR/ADM - CPT CODING UTILITY ;04/20/05
2 ;;3.0; Surgery ;**142**;24 Jun 93
31 N SRCODE,SRDA,SRDATE,SRDES,SRI,SRX
4 S SRDATE=DT
5 S SRDA=$S($G(SRTN):SRTN,$D(DA(1)):DA(1),$D(DA):DA,1:"")
6 I $G(SRDA) S SRDATE=$P($G(^SRF(SRDA,0)),"^",9)
7 S SRDATE=$S($G(ICPTVDT):ICPTVDT,1:SRDATE)
8 S SRCODE=Y,SRX=$$CPTD^ICPTCOD(SRCODE,"SRDES",,SRDATE)
9 F SRI=1:1:SRX D:$TR(SRDES(SRI)," ")'="" EN^DDIOL(SRDES(SRI),"","!,?1")
10 Q
11DISPLAY ; output principal CPT
12 I $D(Y),Y="" Q
13 N SRCODE,SRCPT,SRDA,SRDES,SRI,SRK,SRP,SRW,SRX,SRY,SRZ
14 S Y=$P($$CPT^ICPTCOD(Y),"^",2),SRDA=$S($D(SRTN):SRTN,1:"") Q:SRDA=""
15 I $D(QPQPQ)!$D(SRDIE) D SSPRIN Q
16 D DES I '$O(^SRO(136,SRDA,1,0)) Q
17 S SRCPT="Principal CPT Code: "_SRW D EN^DDIOL(SRCPT,"","!,?6")
18 S SRX="Modifiers: -"
19 S SRI=0 F S SRI=$O(^SRO(136,SRDA,1,SRI)) Q:'SRI D
20 .S SRZ=$P(^SRO(136,SRDA,1,SRI,0),"^"),SRY=$$MOD^ICPTMOD(SRZ,"I",$P($G(^SRF(SRDA,0)),"^",9)),SRX=SRX_$P(SRY,"^",2)_" "_$E($P(SRY,"^",3),1,57) D EN^DDIOL(SRX,"","!,?7") S SRX=" -"
21 W !
22 Q
23OTHDISP ; output other procedure CPT
24 I $D(Y),Y="" Q
25 N SRCODE,SRCPT,SRDA,SRDES,SRI,SRK,SRP,SRW,SRX,SRY,SRZ
26 S Y=$P($$CPT^ICPTCOD(Y),"^",2),SRDA(1)=$S($D(SRTN):SRTN,1:""),SRDA=$S($D(DA):DA,1:"") Q:SRDA(1)=""!(SRDA="")
27 I $D(QPQPQ)!$D(SRDIE) D SSOTH Q
28 D DES I '$O(^SRO(136,SRDA(1),3,SRDA,1,0)) Q
29 S SRCPT="Other CPT Code: "_SRW D EN^DDIOL(SRCPT,"","!,?6")
30 S SRX="Modifiers: -"
31 S SRI=0 F S SRI=$O(^SRO(136,SRDA(1),3,SRDA,1,SRI)) Q:'SRI D
32 .S SRZ=$P(^SRO(136,SRDA(1),3,SRDA,1,SRI,0),"^"),SRY=$$MOD^ICPTMOD(SRZ,"I",$P($G(^SRF(SRDA(1),0)),"^",9)),SRX=SRX_$P(SRY,"^",2)_" "_$E($P(SRY,"^",3),1,57) D EN^DDIOL(SRX,"","!,?7") S SRX=" -"
33 Q
34DES ; get short name and description
35 N X,Z,SRDAA,SRDD S (SRCODE,SRK)=Y,SRDAA=$S($D(SRTN):SRTN,$D(SRDA(1)):SRDA(1),$D(SRDA):SRDA,1:"")
36 S SRDD=DT I $G(SRDAA) S SRDD=$E($P(^SRF(SRDAA,0),"^",9),1,7)
37 S SRY=$$CPT^ICPTCOD(SRCODE,SRDD),SRK=$P(SRY,"^",2),SRW=SRK_" "_$P(SRY,"^",3)
38 S SRY=$$CPTD^ICPTCOD(SRCODE,"SRDES",,SRDD),SRK=SRK_" " F SRI=1:1:SRY D Q:$L(SRK_" "_X)>245 S SRK=SRK_" "_X
39 .S X=SRDES(SRI) F S Z=$F(X," ") Q:'Z S X=$E(X,1,Z-2)_$E(X,Z,255)
40 S Y=SRK
41 Q
42ACTIV(SRTN,SRCODE) ; screen for active CPT codes
43 K ICPTVDT
44 N SROK,SRSDATE S SROK=1,SRSDATE=DT
45 I $G(SRTN) S SRSDATE=$E($P(^SRF(SRTN,0),"^",9),1,7)
46 S SROK=$P($$CPT^ICPTCOD(SRCODE,SRSDATE),"^",7),ICPTVDT=SRSDATE
47 Q SROK
48IN ; check CPT input
49 N SRX,SRCPT K SRCMOD S SRX=X,SRCPT=$P(SRX,"-"),SRCMOD=$P(SRX,"-",2) I SRCMOD="" K SRCMOD
50 S X=SRCPT
51 Q
52DUP ; check for duplicate other procedure CPT
53 N SRX,SRQ
54 S (SRQ,SRX)=0 F S SRX=$O(^SRO(136,SRTN,3,SRX)) Q:'SRX D Q:SRQ
55 .I $D(DA),SRX=DA S SRQ=1 Q
56 .I $P($G(^SRO(136,SRTN,3,SRX,0)),U)=X D EN^DDIOL("This code has already been selected. Please try again.","","!,?5") K X S SRQ=1 Q
57 Q
58SSPRIN ; append CPT modifiers to principal CPT code
59 N SRCMOD,SRCOMMA,SRCPT,SRI,SRM,X I $O(^SRO(136,SRTN,1,0)) D
60 .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=Y_"-" F S SRI=$O(^SRO(136,SRTN,1,SRI)) Q:'SRI D
61 ..S SRM=$P(^SRO(136,SRTN,1,SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2)
62 ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1
63 .S Y=SRCPT
64 Q
65SSOTH ; append CPT modifiers to other CPT code
66 N SRCMOD,SRCOMMA,SRCPT,SRI,SRM,X I $O(^SRO(136,SRTN,3,SRDA,1,0)) D
67 .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=Y_"-" F S SRI=$O(^SRO(136,SRTN,3,SRDA,1,SRI)) Q:'SRI D
68 ..S SRM=$P(^SRO(136,SRTN,3,SRDA,1,SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2)
69 ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1
70 .S Y=SRCPT
71 Q
Note: See TracBrowser for help on using the repository browser.