- 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