source: WorldVistAEHR/trunk/r/SURGERY-SR/SROPOST0.m@ 1800

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

initial load of WorldVistAEHR

File size: 3.7 KB
RevLine 
[613]1SROPOST0 ;B'HAM ISC/MAM,ADM - POST INITS (CONT) ; 20 MAR 1992 12:00 pm
2 ;;3.0; Surgery ;**2,20,24**;24 Jun 93
3 I 'SRVER!'$D(^SRO(132.9)) D NEWSP Q
4 W !!,"The post initialization process will now loop through the Surgery file to",!,"perform the following tasks:",!,"(1) Update the Anesthetist Category field"
5 W !,"(2) Convert existing attending codes to correspond with the new set of codes",!,"(3) Clean up dangling 'LOCK' nodes",!,"(4) Update existing outcome to match new format"
6 W !,"(5) Update surgery position entries to the new multiple format"
7 W !!,"(A dot will be printed for every 100 cases processed) "
8 S (CNT,SRTN)=0 F S SRTN=$O(^SRF(SRTN)) Q:'SRTN S CNT=CNT+1 W:'(CNT#100) "." K:'$D(^SRF(SRTN,0)) ^SRF(SRTN) I $D(^SRF(SRTN,0)) D ANUP,CODE,LOCK,POS,OUT,B
9DEL W !!,"Deleting the ATTENDING CODE file (132.9)..."
10 S DIU="^SRO(132.9,",DIU(0)="" D EN^DIU2 K ^SRO(132.9)
11 W !!,"Now cleaning up dangling 'AL' and 'AUD' cross references." D CLEAN
12 S X1=DT,X2="-30" D C^%DTC S SRSDATE=X-.0001 F S SRSDATE=$O(^SRF("AC",SRSDATE)) Q:'SRSDATE S SRTN=0 F S SRTN=$O(^SRF("AC",SRSDATE,SRTN)) Q:'SRTN D AR
13 W !!,"Deleting 'WL' cross reference..." K ^SRO(133.8,"WL")
14 W !!,"Re-indexing the SURGERY WAITING LIST file..."
15 S DIK="^SRO(133.8," D IXALL^DIK
16NEWSP W !!,"This portion of the post initialization routine will update the SURGICAL",!,"SPECIALTY file (45.3) if necessary."
17 F SHEMP=500:1:502 S CURLEY=$O(^DIC(45.3,"B",SHEMP,0)) I 'CURLEY D SP
18 K CNT,CODE,CURLEY,DA,DIC,DIE,DIK,DR,MM,MMM,SHEMP,SRSP,SRTN,X,Y
19 Q
20CODE S CODE=$P($G(^SRF(SRTN,.1)),"^",16) I CODE="" Q
21 S Y=$P(^SRO(132.9,CODE,0),"^",2),CODE=$S(Y=0:0,Y=1:1,Y=2:2,1:3)
22 K DR,DIE,DA S DR=".165////"_CODE,DA=SRTN,DIE=130 D ^DIE
23 Q
24ANUP ; set ANESTHETIST CATEGORY
25 I $P($G(^SRF(SRTN,.3)),"^")="" Q
26 K DIK S DA=SRTN,DIK="^SRF(",DIK(1)=".31^ANES" D EN1^DIK K DIK,DA
27 Q
28SP ; set specialty
29 S SRSP=$S(SHEMP=500:"CARDIAC SURGERY",SHEMP=501:"TRANSPLANTATION",1:"ANESTHESIOLOGY")
30 K DIE,DD,DIC,D0,DA S X=SHEMP,DIC="^DIC(45.3,",DIC(0)="L",DLAYGO=45.3 D FILE^DICN K DR,DLAYGO S DA=+Y,DIE=45.3,DR="1///"_SRSP W !!,"Adding "_SHEMP_" "_SRSP_" to the SURGICAL SPECIALTY file (45.3)..." D ^DIE K DR
31 Q
32POS ; update surgery position entries to multiple format
33 I $P($G(^SRF(SRTN,.5)),"^",3)="" Q
34 S ^SRF(SRTN,42,0)="^130.065P^1^1",^SRF(SRTN,42,1,0)=$P(^SRF(SRTN,.5),"^",3),$P(^SRF(SRTN,.5),"^",3)=""
35 Q
36OUT I $O(^SRF(SRTN,10,0)) S X=0 F S X=$O(^SRF(SRTN,10,X)) Q:'X S Y=$P(^SRF(SRTN,10,X,0),"^",6) D REPLACE S $P(^SRF(SRTN,10,X,0),"^",6)=MM
37 I $O(^SRF(SRTN,16,0)) S X=0 F S X=$O(^SRF(SRTN,16,X)) Q:'X S Y=$P(^SRF(SRTN,16,X,0),"^",6) D REPLACE S $P(^SRF(SRTN,16,X,0),"^",6)=MM
38 I $O(^SRF(SRTN,36,0)) S X=0 F S X=$O(^SRF(SRTN,36,X)) Q:'X S Y=$P(^SRF(SRTN,36,X,0),"^",2) D REPLACE S $P(^SRF(SRTN,36,X,0),"^",2)=MM
39 Q
40REPLACE S MM=$S(Y="N":"I",Y="E":"I",Y="P":"I",1:Y)
41 Q
42CLEAN ; clean up dangling 'AL' & 'AUD' x-refs
43 S SRTN=0 F S SRTN=$O(^SRF("AUD",SRTN)) Q:'SRTN I '$D(^SRF(SRTN,0)) K ^SRF("AUD",SRTN)
44 S SRTN=0 F S SRTN=$O(^SRF("AL",SRTN)) Q:'SRTN I '$D(^SRF(SRTN,0)) K ^SRF("AL",SRTN)
45 Q
46LOCK ; clean up dangling 'LOCK' nodes
47 I $D(^SRF(SRTN,"LOCK")),'$D(^SRF(SRTN,0)) K ^SRF(SRTN,"LOCK")
48 Q
49AR ; create 'AR' x-ref
50 S REQ=$P($G(^SRF(SRTN,"REQ")),"^") I 'REQ Q
51 S SCH=$P($G(^SRF(SRTN,31)),"^",4) I SCH Q
52 I $P($G(^SRF(SRTN,31)),"^",8)'=""!($P($G(^SRF(SRTN,30)),"^")'="") Q
53 S DFN=$P(^SRF(SRTN,0),"^"),^SRF("AR",$E(SRSDATE,1,7),DFN,SRTN)=""
54 Q
55B ; delete B x-ref on anesthesia agent
56 I $D(^SRF(SRTN,6)) S TECH=0 F S TECH=$O(^SRF(SRTN,6,TECH)) Q:'TECH K ^SRF(SRTN,6,TECH,1,"B")
57 Q
58P24 ; entry for update of surgery position for SR*3*24
59 W !!,"This process will update surgery position entries to the multiple format. "
60 S (CNT,SRTN)=0 F S SRTN=$O(^SRF(SRTN)) Q:'SRTN S CNT=CNT+1 W:'(CNT#100) "." I '$O(^SRF(SRTN,42,0)) D POS
61 K CNT,SRTN W !!,"Finished."
62 Q
Note: See TracBrowser for help on using the repository browser.