source: WorldVistAEHR/trunk/r/SURGERY-SR/SROAOTH.m@ 1259

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

initial load of WorldVistAEHR

File size: 1.7 KB
Line 
1SROAOTH ;BIR/MAM - PRINT OTHER PROCEDURES ;04/11/06
2 ;;3.0; Surgery ;**34,88,97,142,153**;24 Jun 93;Build 11
3 N CPTT
4 W ! S (CNT,OTH)=0,CPTT="" F S OTH=$O(^SRF(SRTN,13,OTH)) Q:'OTH S CNT=CNT+1,OPER=$P(^SRF(SRTN,13,OTH,0),"^"),CPT=$P($G(^SRF(SRTN,13,OTH,2)),"^") D LIST
5 S X=$P($G(^SRO(136,SRTN,0)),"^",2) I X S Y=$S(X:$P($$CPT^ICPTCOD(X),"^",2),1:"") D SSPRIN^SROCPT0 S CPTT=Y I $L(Y),$O(^SRO(136,SRTN,3,0)) D
6 .S OTH=0 F S OTH=$O(^SRO(136,SRTN,3,OTH)) Q:'OTH S OPER=$P($G(^SRO(136,SRTN,3,OTH,0)),"^"),CPT=$P($G(^SRO(136,SRTN,3,OTH,0)),"^") D
7 ..I CPT S Y=$P($$CPT^ICPTCOD(CPT),"^",2),SRDA=OTH D SSOTH^SROCPT0 S CPT=Y I $L(CPT) S CPTT=CPTT_", "_CPT
8 W !!,$J("Procedure CPT Codes: ",39)_CPTT
9 K OTH,CPT,CNT,OPER,SROPS S SROPS(1)=""
10 S CPT="",CON=$P($G(^SRF(SRTN,"CON")),"^") I CON,($P($G(^SRF(CON,30)),"^")!($P($G(^SRF(CON,31)),"^",8))) S CON=""
11 I CON S SROPER=$P(^SRF(CON,"OP"),"^"),CPT=$P($G(^SRO(136,CON,0)),"^",2) D
12 .K SROPS,MM,MMM S:$L(SROPER)<49 SROPS(1)=SROPER I $L(SROPER)>48 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM=""
13 .I CPT S Y=$P($$CPT^ICPTCOD(CPT),"^",2) D CON
14 .S:CPT="" CPT="MISSING"
15 W !!,$J("Concurrent Procedure: ",39)_$S(SROPS(1)="":"N/A",1:SROPS(1)) I $D(SROPS(2)) W !,?39,SROPS(2) I $D(SROPS(3)) W !,?39,SROPS(3)
16 W !,$J("CPT Code: ",39)_$S(CPT="":"N/A",1:CPT)
17 Q
18CON ; get CPT modifiers for concurrent procedure
19 N SRTN S SRTN=CON D SSPRIN^SROCPT0 S CPT=Y
20 Q
21LIST I CPT S Y=$P($$CPT^ICPTCOD(CPT),"^",2),SRDA=OTH D SSOTH^SROCPT S CPT=Y
22 S:CPT="" CPT="MISSING"
23 W !,$J("Other Procedure ("_CNT_"): ",39)_OPER
24 Q
25LOOP ; break procedures
26 S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<49 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
27 Q
Note: See TracBrowser for help on using the repository browser.