Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ASDPOST

ASDPOST.m

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