- SROPOST0 ;B'HAM ISC/MAM,ADM - POST INITS (CONT) ; 20 MAR 1992 12:00 pm
- ;;3.0; Surgery ;**2,20,24**;24 Jun 93
- I 'SRVER!'$D(^SRO(132.9)) D NEWSP Q
- W !!,"The post initialization process will now loop through the Surgery file to",!,"perform the following tasks:",!,"(1) Update the Anesthetist Category field"
- 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"
- W !,"(5) Update surgery position entries to the new multiple format"
- W !!,"(A dot will be printed for every 100 cases processed) "
- 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
- DEL W !!,"Deleting the ATTENDING CODE file (132.9)..."
- S DIU="^SRO(132.9,",DIU(0)="" D EN^DIU2 K ^SRO(132.9)
- W !!,"Now cleaning up dangling 'AL' and 'AUD' cross references." D CLEAN
- 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
- W !!,"Deleting 'WL' cross reference..." K ^SRO(133.8,"WL")
- W !!,"Re-indexing the SURGERY WAITING LIST file..."
- S DIK="^SRO(133.8," D IXALL^DIK
- NEWSP W !!,"This portion of the post initialization routine will update the SURGICAL",!,"SPECIALTY file (45.3) if necessary."
- F SHEMP=500:1:502 S CURLEY=$O(^DIC(45.3,"B",SHEMP,0)) I 'CURLEY D SP
- K CNT,CODE,CURLEY,DA,DIC,DIE,DIK,DR,MM,MMM,SHEMP,SRSP,SRTN,X,Y
- Q
- CODE S CODE=$P($G(^SRF(SRTN,.1)),"^",16) I CODE="" Q
- S Y=$P(^SRO(132.9,CODE,0),"^",2),CODE=$S(Y=0:0,Y=1:1,Y=2:2,1:3)
- K DR,DIE,DA S DR=".165////"_CODE,DA=SRTN,DIE=130 D ^DIE
- Q
- ANUP ; set ANESTHETIST CATEGORY
- I $P($G(^SRF(SRTN,.3)),"^")="" Q
- K DIK S DA=SRTN,DIK="^SRF(",DIK(1)=".31^ANES" D EN1^DIK K DIK,DA
- Q
- SP ; set specialty
- S SRSP=$S(SHEMP=500:"CARDIAC SURGERY",SHEMP=501:"TRANSPLANTATION",1:"ANESTHESIOLOGY")
- 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
- Q
- POS ; update surgery position entries to multiple format
- I $P($G(^SRF(SRTN,.5)),"^",3)="" Q
- S ^SRF(SRTN,42,0)="^130.065P^1^1",^SRF(SRTN,42,1,0)=$P(^SRF(SRTN,.5),"^",3),$P(^SRF(SRTN,.5),"^",3)=""
- Q
- OUT 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
- 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
- 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
- Q
- REPLACE S MM=$S(Y="N":"I",Y="E":"I",Y="P":"I",1:Y)
- Q
- CLEAN ; clean up dangling 'AL' & 'AUD' x-refs
- S SRTN=0 F S SRTN=$O(^SRF("AUD",SRTN)) Q:'SRTN I '$D(^SRF(SRTN,0)) K ^SRF("AUD",SRTN)
- S SRTN=0 F S SRTN=$O(^SRF("AL",SRTN)) Q:'SRTN I '$D(^SRF(SRTN,0)) K ^SRF("AL",SRTN)
- Q
- LOCK ; clean up dangling 'LOCK' nodes
- I $D(^SRF(SRTN,"LOCK")),'$D(^SRF(SRTN,0)) K ^SRF(SRTN,"LOCK")
- Q
- AR ; create 'AR' x-ref
- S REQ=$P($G(^SRF(SRTN,"REQ")),"^") I 'REQ Q
- S SCH=$P($G(^SRF(SRTN,31)),"^",4) I SCH Q
- I $P($G(^SRF(SRTN,31)),"^",8)'=""!($P($G(^SRF(SRTN,30)),"^")'="") Q
- S DFN=$P(^SRF(SRTN,0),"^"),^SRF("AR",$E(SRSDATE,1,7),DFN,SRTN)=""
- Q
- B ; delete B x-ref on anesthesia agent
- 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")
- Q
- P24 ; entry for update of surgery position for SR*3*24
- W !!,"This process will update surgery position entries to the multiple format. "
- 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
- K CNT,SRTN W !!,"Finished."
- Q
- SROPOST0 ;B'HAM ISC/MAM,ADM - POST INITS (CONT) ; 20 MAR 1992 12:00 pm
- +1 ;;3.0; Surgery ;**2,20,24**;24 Jun 93
- +2 IF 'SRVER!'$DATA(^SRO(132.9))
- DO NEWSP
- QUIT
- +3 WRITE !!,"The post initialization process will now loop through the Surgery file to",!,"perform the following tasks:",!,"(1) Update the Anesthetist Category field"
- +4 WRITE !,"(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"
- +5 WRITE !,"(5) Update surgery position entries to the new multiple format"
- +6 WRITE !!,"(A dot will be printed for every 100 cases processed) "
- +7 SET (CNT,SRTN)=0
- FOR
- SET SRTN=$ORDER(^SRF(SRTN))
- IF 'SRTN
- QUIT
- SET CNT=CNT+1
- IF '(CNT#100)
- WRITE "."
- IF '$DATA(^SRF(SRTN,0))
- KILL ^SRF(SRTN)
- IF $DATA(^SRF(SRTN,0))
- DO ANUP
- DO CODE
- DO LOCK
- DO POS
- DO OUT
- DO B
- DEL WRITE !!,"Deleting the ATTENDING CODE file (132.9)..."
- +1 SET DIU="^SRO(132.9,"
- SET DIU(0)=""
- DO EN^DIU2
- KILL ^SRO(132.9)
- +2 WRITE !!,"Now cleaning up dangling 'AL' and 'AUD' cross references."
- DO CLEAN
- +3 SET X1=DT
- SET X2="-30"
- DO C^%DTC
- SET SRSDATE=X-.0001
- FOR
- SET SRSDATE=$ORDER(^SRF("AC",SRSDATE))
- IF 'SRSDATE
- QUIT
- SET SRTN=0
- FOR
- SET SRTN=$ORDER(^SRF("AC",SRSDATE,SRTN))
- IF 'SRTN
- QUIT
- DO AR
- +4 WRITE !!,"Deleting 'WL' cross reference..."
- KILL ^SRO(133.8,"WL")
- +5 WRITE !!,"Re-indexing the SURGERY WAITING LIST file..."
- +6 SET DIK="^SRO(133.8,"
- DO IXALL^DIK
- NEWSP WRITE !!,"This portion of the post initialization routine will update the SURGICAL",!,"SPECIALTY file (45.3) if necessary."
- +1 FOR SHEMP=500:1:502
- SET CURLEY=$ORDER(^DIC(45.3,"B",SHEMP,0))
- IF 'CURLEY
- DO SP
- +2 KILL CNT,CODE,CURLEY,DA,DIC,DIE,DIK,DR,MM,MMM,SHEMP,SRSP,SRTN,X,Y
- +3 QUIT
- CODE SET CODE=$PIECE($GET(^SRF(SRTN,.1)),"^",16)
- IF CODE=""
- QUIT
- +1 SET Y=$PIECE(^SRO(132.9,CODE,0),"^",2)
- SET CODE=$SELECT(Y=0:0,Y=1:1,Y=2:2,1:3)
- +2 KILL DR,DIE,DA
- SET DR=".165////"_CODE
- SET DA=SRTN
- SET DIE=130
- DO ^DIE
- +3 QUIT
- ANUP ; set ANESTHETIST CATEGORY
- +1 IF $PIECE($GET(^SRF(SRTN,.3)),"^")=""
- QUIT
- +2 KILL DIK
- SET DA=SRTN
- SET DIK="^SRF("
- SET DIK(1)=".31^ANES"
- DO EN1^DIK
- KILL DIK,DA
- +3 QUIT
- SP ; set specialty
- +1 SET SRSP=$SELECT(SHEMP=500:"CARDIAC SURGERY",SHEMP=501:"TRANSPLANTATION",1:"ANESTHESIOLOGY")
- +2 KILL DIE,DD,DIC,D0,DA
- SET X=SHEMP
- SET DIC="^DIC(45.3,"
- SET DIC(0)="L"
- SET DLAYGO=45.3
- DO FILE^DICN
- KILL DR,DLAYGO
- SET DA=+Y
- SET DIE=45.3
- SET DR="1///"_SRSP
- WRITE !!,"Adding "_SHEMP_" "_SRSP_" to the SURGICAL SPECIALTY file (45.3)..."
- DO ^DIE
- KILL DR
- +3 QUIT
- POS ; update surgery position entries to multiple format
- +1 IF $PIECE($GET(^SRF(SRTN,.5)),"^",3)=""
- QUIT
- +2 SET ^SRF(SRTN,42,0)="^130.065P^1^1"
- SET ^SRF(SRTN,42,1,0)=$PIECE(^SRF(SRTN,.5),"^",3)
- SET $PIECE(^SRF(SRTN,.5),"^",3)=""
- +3 QUIT
- OUT IF $ORDER(^SRF(SRTN,10,0))
- SET X=0
- FOR
- SET X=$ORDER(^SRF(SRTN,10,X))
- IF 'X
- QUIT
- SET Y=$PIECE(^SRF(SRTN,10,X,0),"^",6)
- DO REPLACE
- SET $PIECE(^SRF(SRTN,10,X,0),"^",6)=MM
- +1 IF $ORDER(^SRF(SRTN,16,0))
- SET X=0
- FOR
- SET X=$ORDER(^SRF(SRTN,16,X))
- IF 'X
- QUIT
- SET Y=$PIECE(^SRF(SRTN,16,X,0),"^",6)
- DO REPLACE
- SET $PIECE(^SRF(SRTN,16,X,0),"^",6)=MM
- +2 IF $ORDER(^SRF(SRTN,36,0))
- SET X=0
- FOR
- SET X=$ORDER(^SRF(SRTN,36,X))
- IF 'X
- QUIT
- SET Y=$PIECE(^SRF(SRTN,36,X,0),"^",2)
- DO REPLACE
- SET $PIECE(^SRF(SRTN,36,X,0),"^",2)=MM
- +3 QUIT
- REPLACE SET MM=$SELECT(Y="N":"I",Y="E":"I",Y="P":"I",1:Y)
- +1 QUIT
- CLEAN ; clean up dangling 'AL' & 'AUD' x-refs
- +1 SET SRTN=0
- FOR
- SET SRTN=$ORDER(^SRF("AUD",SRTN))
- IF 'SRTN
- QUIT
- IF '$DATA(^SRF(SRTN,0))
- KILL ^SRF("AUD",SRTN)
- +2 SET SRTN=0
- FOR
- SET SRTN=$ORDER(^SRF("AL",SRTN))
- IF 'SRTN
- QUIT
- IF '$DATA(^SRF(SRTN,0))
- KILL ^SRF("AL",SRTN)
- +3 QUIT
- LOCK ; clean up dangling 'LOCK' nodes
- +1 IF $DATA(^SRF(SRTN,"LOCK"))
- IF '$DATA(^SRF(SRTN,0))
- KILL ^SRF(SRTN,"LOCK")
- +2 QUIT
- AR ; create 'AR' x-ref
- +1 SET REQ=$PIECE($GET(^SRF(SRTN,"REQ")),"^")
- IF 'REQ
- QUIT
- +2 SET SCH=$PIECE($GET(^SRF(SRTN,31)),"^",4)
- IF SCH
- QUIT
- +3 IF $PIECE($GET(^SRF(SRTN,31)),"^",8)'=""!($PIECE($GET(^SRF(SRTN,30)),"^")'="")
- QUIT
- +4 SET DFN=$PIECE(^SRF(SRTN,0),"^")
- SET ^SRF("AR",$EXTRACT(SRSDATE,1,7),DFN,SRTN)=""
- +5 QUIT
- B ; delete B x-ref on anesthesia agent
- +1 IF $DATA(^SRF(SRTN,6))
- SET TECH=0
- FOR
- SET TECH=$ORDER(^SRF(SRTN,6,TECH))
- IF 'TECH
- QUIT
- KILL ^SRF(SRTN,6,TECH,1,"B")
- +2 QUIT
- P24 ; entry for update of surgery position for SR*3*24
- +1 WRITE !!,"This process will update surgery position entries to the multiple format. "
- +2 SET (CNT,SRTN)=0
- FOR
- SET SRTN=$ORDER(^SRF(SRTN))
- IF 'SRTN
- QUIT
- SET CNT=CNT+1
- IF '(CNT#100)
- WRITE "."
- IF '$ORDER(^SRF(SRTN,42,0))
- DO POS
- +3 KILL CNT,SRTN
- WRITE !!,"Finished."
- +4 QUIT
