ASDPOST ; IHS/ADC/PDW/ENM - IHS POST-INITS ; [ 03/25/1999 11:48 AM ]
;;5.0;IHS SCHEDULING;;MAR 25, 1999
;
D ^SDONIT,^ASDL,XREF,KEYS,ADD,ADD2,DIV,FIX202 Q
;
XREF ; -- run new cross-references
W !!,"RUNNING NEW CROSS-REFERENCES. . .",!
S DIK="^SC(",DIK(1)=1916 D ENALL^DIK ; x-ref princ clinic
S DIK="^SC(",DIK(1)=2501 D ENALL^DIK ; x-ref priv user
S DIK="^SC(",DIK(1)=9999999.01 D ENALL^DIK ; x-ref ob user
Q
;
KEYS ; -- gives SDZSUP1 key to holders of SDZSUP key
S ASDK=$O(^DIC(19.1,"B","SDZSUP1",0)) Q:ASDK=""
W !!,"ASSIGNING NEW SUPERVISOR KEY TO USERS WITH OLD KEY. . .",!
S ASDU=0
F S ASDU=$O(^XUSEC("SDZSUP",ASDU)) Q:ASDU="" D
. Q:$D(^XUSEC("SDZSUP1",ASDU)) ;already has new key
. K DIC,DD,DO S DIC(0)="NMQ",DIC("P")="200.051PA"
. S DIC="^VA(200,"_ASDU_",51,",DA(1)=ASDU,X=ASDK,DINUM=X
. D FILE^DICN W "."
K DIC,DINUM,DA,ASDU,ASDK
;
; -- give SDZMENU key to all current holders of SDZUSER
S ASDK=$O(^DIC(19.1,"B","SDZMENU",0)) Q:ASDK=""
W !!,"ASSIGNING NEW SCHEDULING KEY TO USERS WITH OLD KEY. . .",!
S ASDU=0
F S ASDU=$O(^XUSEC("SDZUSER",ASDU)) Q:ASDU="" D
. Q:$D(^XUSEC("SDZMENU",ASDU)) ;already has new key
. K DIC,DD,DO S DIC(0)="NMQ",DIC("P")="200.051PA"
. S DIC="^VA(200,"_ASDU_",51,",DA(1)=ASDU,X=ASDK,DINUM=X
. D FILE^DICN W "."
K DIC,DINUM,DA,ASDU,ASDK
Q
;
ADD ; -- add MAS Parameter entry if none
Q:$D(^DG(43,1,0))
K DIC S DIC(0)="L",DLAYGO=43,DIC=43,X=1 D ^DIC
Q
;
ADD2 ; -- make sure at least one entry for med cneter division
Q:$O(^DG(40.8,0))
K DIC S DIC=40.8,DLAYGO=40,DIC(0)="L",X=$P($G(^DIC(4,DUZ(2),0)),U)
Q:X="" D ^DIC Q:Y<1
S DIE=40.8,DA=+Y,DR="1///"_DUZ(2) D ^DIE
Q
;
DIV ; -- stuff division into clinics without an entry
Q:'$D(^DG(40.8,"C",DUZ(2)))
W !!,"UPDATING DIVISION FIELD IN CLINICS. . .",!
S ASDIV=$O(^DG(40.8,"C",DUZ(2))) Q:ASDIV=""
S ASDC=0 F S ASDC=$O(^SC(ASDC)) Q:'ASDC D
. Q:'$D(^SC(ASDC,0))
. Q:$P(^SC(ASDC,0),U,15)]""
. S DIE="^SC(",DA=ASDC,DR="3.5////ASDIV" D ^DIE
K ASDIV,ASDC,DIE,DA,DR
Q
;
FIX202 ; -- cleans out 202.1 node of file 200
NEW X
S X=0 F S X=$O(^VA(200,X)) Q:'X D
. I $G(^VA(200,X,202.1))]"" S ^VA(200,X,202.1)=""
Q
ASDPOST ; IHS/ADC/PDW/ENM - IHS POST-INITS ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;IHS SCHEDULING;;MAR 25, 1999
+2 ;
+3 DO ^SDONIT
DO ^ASDL
DO XREF
DO KEYS
DO ADD
DO ADD2
DO DIV
DO FIX202
QUIT
+4 ;
XREF ; -- run new cross-references
+1 WRITE !!,"RUNNING NEW CROSS-REFERENCES. . .",!
+2 ; x-ref princ clinic
SET DIK="^SC("
SET DIK(1)=1916
DO ENALL^DIK
+3 ; x-ref priv user
SET DIK="^SC("
SET DIK(1)=2501
DO ENALL^DIK
+4 ; x-ref ob user
SET DIK="^SC("
SET DIK(1)=9999999.01
DO ENALL^DIK
+5 QUIT
+6 ;
KEYS ; -- gives SDZSUP1 key to holders of SDZSUP key
+1 SET ASDK=$ORDER(^DIC(19.1,"B","SDZSUP1",0))
IF ASDK=""
QUIT
+2 WRITE !!,"ASSIGNING NEW SUPERVISOR KEY TO USERS WITH OLD KEY. . .",!
+3 SET ASDU=0
+4 FOR
SET ASDU=$ORDER(^XUSEC("SDZSUP",ASDU))
IF ASDU=""
QUIT
Begin DoDot:1
+5 ;already has new key
IF $DATA(^XUSEC("SDZSUP1",ASDU))
QUIT
+6 KILL DIC,DD,DO
SET DIC(0)="NMQ"
SET DIC("P")="200.051PA"
+7 SET DIC="^VA(200,"_ASDU_",51,"
SET DA(1)=ASDU
SET X=ASDK
SET DINUM=X
+8 DO FILE^DICN
WRITE "."
End DoDot:1
+9 KILL DIC,DINUM,DA,ASDU,ASDK
+10 ;
+11 ; -- give SDZMENU key to all current holders of SDZUSER
+12 SET ASDK=$ORDER(^DIC(19.1,"B","SDZMENU",0))
IF ASDK=""
QUIT
+13 WRITE !!,"ASSIGNING NEW SCHEDULING KEY TO USERS WITH OLD KEY. . .",!
+14 SET ASDU=0
+15 FOR
SET ASDU=$ORDER(^XUSEC("SDZUSER",ASDU))
IF ASDU=""
QUIT
Begin DoDot:1
+16 ;already has new key
IF $DATA(^XUSEC("SDZMENU",ASDU))
QUIT
+17 KILL DIC,DD,DO
SET DIC(0)="NMQ"
SET DIC("P")="200.051PA"
+18 SET DIC="^VA(200,"_ASDU_",51,"
SET DA(1)=ASDU
SET X=ASDK
SET DINUM=X
+19 DO FILE^DICN
WRITE "."
End DoDot:1
+20 KILL DIC,DINUM,DA,ASDU,ASDK
+21 QUIT
+22 ;
ADD ; -- add MAS Parameter entry if none
+1 IF $DATA(^DG(43,1,0))
QUIT
+2 KILL DIC
SET DIC(0)="L"
SET DLAYGO=43
SET DIC=43
SET X=1
DO ^DIC
+3 QUIT
+4 ;
ADD2 ; -- make sure at least one entry for med cneter division
+1 IF $ORDER(^DG(40.8,0))
QUIT
+2 KILL DIC
SET DIC=40.8
SET DLAYGO=40
SET DIC(0)="L"
SET X=$PIECE($GET(^DIC(4,DUZ(2),0)),U)
+3 IF X=""
QUIT
DO ^DIC
IF Y<1
QUIT
+4 SET DIE=40.8
SET DA=+Y
SET DR="1///"_DUZ(2)
DO ^DIE
+5 QUIT
+6 ;
DIV ; -- stuff division into clinics without an entry
+1 IF '$DATA(^DG(40.8,"C",DUZ(2)))
QUIT
+2 WRITE !!,"UPDATING DIVISION FIELD IN CLINICS. . .",!
+3 SET ASDIV=$ORDER(^DG(40.8,"C",DUZ(2)))
IF ASDIV=""
QUIT
+4 SET ASDC=0
FOR
SET ASDC=$ORDER(^SC(ASDC))
IF 'ASDC
QUIT
Begin DoDot:1
+5 IF '$DATA(^SC(ASDC,0))
QUIT
+6 IF $PIECE(^SC(ASDC,0),U,15)]""
QUIT
+7 SET DIE="^SC("
SET DA=ASDC
SET DR="3.5////ASDIV"
DO ^DIE
End DoDot:1
+8 KILL ASDIV,ASDC,DIE,DA,DR
+9 QUIT
+10 ;
FIX202 ; -- cleans out 202.1 node of file 200
+1 NEW X
+2 SET X=0
FOR
SET X=$ORDER(^VA(200,X))
IF 'X
QUIT
Begin DoDot:1
+3 IF $GET(^VA(200,X,202.1))]""
SET ^VA(200,X,202.1)=""
End DoDot:1
+4 QUIT
