source: WorldVistAEHR/trunk/r/SURGERY-SR/SROAOPS.m@ 1484

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

initial load of WorldVistAEHR

File size: 2.6 KB
RevLine 
[613]1SROAOPS ;BIR/MAM - OTHER PROCEDURES ; 17 MAR 1992 1:30 pm [ 12/15/98 12:51 PM ]
2 ;;3.0; Surgery ;**88**;24 Jun 93
3OTHER ; other procedures
4 I '$D(^SRF(SRTN,13,0)) S ^SRF(SRTN,13,0)="^130.16A^0^0"
5 K SRAOTH F I=1:1:5 S SRAOTH(I)=""
6 S (OPS,CNT)=0 F S OPS=$O(^SRF(SRTN,13,OPS)) Q:'OPS D SETOP
7 D HDR
8 W !,"1. Other Procedure (1):" I $D(SRAOTH(1)) W ?25,$P(SRAOTH(1),"^")
9 W !," CPT Code:" I $D(SRAOTH("1A")) W ?25,$P(SRAOTH("1A"),"^")
10 W !!,"2. Other Procedure (2):" I $D(SRAOTH(2)) W ?25,$P(SRAOTH(2),"^")
11 W !," CPT Code:" I $D(SRAOTH("2A")) W ?25,$P(SRAOTH("2A"),"^")
12 W !!,"3. Other Procedure (3):" I $D(SRAOTH(3)) W ?25,$P(SRAOTH(3),"^")
13 W !," CPT Code:" I $D(SRAOTH("3A")) W ?25,$P(SRAOTH("3A"),"^")
14 W !!,"4. Other Procedure (4):" I $D(SRAOTH(4)) W ?25,$P(SRAOTH(4),"^")
15 W !," CPT Code:" I $D(SRAOTH("4A")) W ?25,$P(SRAOTH("4A"),"^")
16 W !!,"5. Other Procedure (5):" I $D(SRAOTH(5)) W ?25,$P(SRAOTH(5),"^")
17 W !," CPT Code:" I $D(SRAOTH("5A")) W ?25,$P(SRAOTH("5A"),"^")
18 W ! F MOE=1:1:80 W "-"
19ASK W !!,"Select Other Operative Procedure Information: " R X:DTIME I '$T!("^"[X) Q
20 I X'="A",'$D(SRAOTH(X)) D HELP G:SRSOUT END G OTHER
21 S:X="A" X="1:5" I X?.N1":".N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>5)!(Y>Z) D HELP G:SRSOUT END G OTHER
22 D HDR I X?.N1":".N D RANGE,HDR G OTHER
23 S KAREN=X D ONE G OTHER
24 Q
25END K SRAOTH,CNT
26 Q
27HELP W @IOF,!!!!!,"Enter the number or range of numbers you want to edit. Examples of proper",!,"responses are listed below."
28 W !!,"1. Enter 'A' to update all information.",!!,"2. Enter a number (1-5) to update one specific procedure. For example, ",!," enter '1' to update Other Procedure (1)."
29 W !!,"3. Enter a range of numbers, separated by a ':' to update more than one",!," procedure. For example, enter '1:2' to enter Other Procedure (1) and",!," Other Procedure (2)."
30 W !!,"Press <RET> to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1
31 Q
32SETOP ; set other operative info
33 S OTHER=^SRF(SRTN,13,OPS,0),CNT=CNT+1,SRAOTH(CNT)=$P(OTHER,"^")_"^"_OPS,X=$P(OTHER,"^",2) S:X X=$P($$CPT^ICPTCOD(X),"^",2) S Y=CNT_"A",SRAOTH(Y)=X_"^"_OPS
34 Q
35RANGE ; range of numbers
36 S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F KAREN=SHEMP:1:CURLEY Q:SRSOUT D ONE
37 Q
38ONE ; edit one procedure
39 W !! I SRAOTH(KAREN)'="" K DR,DIE S DA=$P(SRAOTH(KAREN),"^",2),DIE="^SRF("_SRTN_",11,",DA(1)=SRTN,DR=".01T;1T" D ^DIE K DR Q
40 K DIR,DA S DIR(0)="130.16,.01",DIR("A")="Other Operative Procedure ("_KAREN_")" D ^DIR I Y="" Q
41 K DA,DIC,DD,DO,DINUM S DA(1)=SRTN,X=Y,DIC="^SRF("_SRTN_",13,",DIC(0)="L" D FILE^DICN K DIC,DD,DO
42 K DR,DIE S DA=+Y,DA(1)=SRTN,DR="1T",DIE="^SRF("_SRTN_",13," D ^DIE K DR
43 Q
44HDR W @IOF,!,SRANAME,! F MOE=1:1:80 W "-"
45 Q
Note: See TracBrowser for help on using the repository browser.