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

BSDPOST1.m

Go to the documentation of this file. 
  1. BSDPOST1 ; IHS/ANMC/LJF - SCHEDULING POST INIT CONT. ;  [ 04/09/2004  11:09 AM ]
  1.  ;;5.3;PIMS;;APR 26, 2002
  1.  ;
  1. WAIT ;EP; copy waiting list data into new file structure
  1.  ; ^ASDWL -> ^BSDWL   old data kept until future patch
  1.  Q:$O(^BSDWL(0))   ;already data in new file
  1.  D BMES^XPDUTL("Copying Waiting List data to new file...")
  1.  ;
  1.  NEW OLD,NEW,OLD1,NEW1,DATA,DIK
  1.  S OLD=0 F  S OLD=$O(^ASDWL(OLD)) Q:'OLD  D
  1.  . Q:$G(^ASDWL(OLD,0))=""          ;bad entry
  1.  . S NEW=$G(NEW)+1                 ;ien for new entry in new file
  1.  . S $P(^BSDWL(0),U,3)=NEW,$P(^BSDWL(0),U,4)=$P(^BSDWL(0),U,4)+1
  1.  . S ^BSDWL(NEW,0)=^ASDWL(OLD,0)   ;set zero node
  1.  . ;
  1.  . Q:'$O(^ASDWL(OLD,1,0))          ;no patients for entry
  1.  . S ^BSDWL(NEW,1,0)="^9009017.11P"  ;set zero node
  1.  . ;
  1.  . ; loop thru patient multiple
  1.  . S (OLD1,NEW1)=0 F  S OLD1=$O(^ASDWL(OLD,1,OLD1)) Q:'OLD1  D
  1.  .. S DATA=$G(^ASDWL(OLD,1,OLD1,0)) Q:DATA=""    ;quit if bad entry
  1.  .. S NEW1=NEW1+1,^BSDWL(NEW,1,NEW1,0)=""        ;set zero node
  1.  .. S $P(^BSDWL(NEW,1,0),U,3)=NEW1               ;update multiple node
  1.  .. S $P(^BSDWL(NEW,1,0),U,4)=$P(^BSDWL(NEW,1,0),U,4)+1
  1.  .. ;
  1.  .. ; move data items to new locations
  1.  .. S $P(^BSDWL(NEW,1,NEW1,0),U,1,3)=$P(DATA,U,1,3)
  1.  .. S $P(^BSDWL(NEW,1,NEW1,0),U,5,6)=$P(DATA,U,6,7)
  1.  .. Q:$P(DATA,U,4)=""                            ;quit if no comments
  1.  .. S ^BSDWL(NEW,1,NEW1,1,0)="^9009017.111^1^1"
  1.  .. S ^BSDWL(NEW,1,NEW1,1,1,0)=$P(DATA,U,4)      ;comments now wp field
  1.  ;
  1.  ; index new file
  1.  S DIK="^BSDWL(" D IXALL^DIK
  1.  K X S X=$$REPEAT^XLFSTR(" ",20)_"Done" D MES^XPDUTL(.X)
  1.  Q
  1.  ;
  1.  ;
  1. PARAM ;EP; copy scheduling parameters from file 40.8 to 9009020.2
  1.  ; copy from ^DG(40.8 -> ^BSDPAR (which points back to 40.8 dinumed)
  1.  ; old data will be left in 40.8 until a future patch
  1.  Q:$O(^BSDPAR(0))    ;already has data
  1.  D BMES^XPDUTL("Copying scheduling parameters to IHS file...")
  1.  ;
  1.  NEW DIV,DATA,I,DIK
  1.  S DIV=0 F  S DIV=$O(^DG(40.8,DIV)) Q:'DIV  D
  1.  . S DATA=$G(^DG(40.8,DIV,"IHS")) Q:DATA=""
  1.  . ;
  1.  . ; now copy items into new locations
  1.  . S ^BSDPAR(DIV,0)=DIV,$P(^BSDPAR(0),U,3)=DIV
  1.  . S $P(^BSDPAR(0),U,4)=$P(^BSDPAR(0),U,4)+1
  1.  . F I="1;2","2;16","3;3","4;4","5;5","6;6","8;8","9;19","11;11","12;12","15;15","16;13" S $P(^BSDPAR(DIV,0),U,$P(I,";",2))=$P(DATA,U,+I)
  1.  ;
  1.  ; new index new file
  1.  S DIK="^BSDPAR(" D IXALL^DIK
  1.  K X S X=$$REPEAT^XLFSTR(" ",20)_"Done" D MES^XPDUTL(.X)
  1.  Q
  1.  ;
  1. PCMM ;EP; set up PCMM files for GIU workstation
  1.  D BMES^XPDUTL("Setting up PCMM files - Server side...")
  1.  ;
  1.  NEW DD,DO,DIC,X,Y,DINUM,DLAYGO
  1.  I '$D(^SCTM(404.44,1,0)) D     ;pcmm parameter file
  1.  . K DD,DO S DIC="^SCTM(404.44,",DLAYGO=404.44,DIC(0)="L"
  1.  . S (X,DINUM)=1,DIC("DR")="12///0;13///1;14///30;15///2500;16///14"
  1.  . D FILE^DICN
  1.  . I Y<1 K X S X="PCMM Parameter File Error!" D MES^XPDUTL(.X)
  1.  ;
  1.  I '$D(^SCTM(404.46,"B","1.2.2.0",1)) D   ;pcmm client patch
  1.  . K DD,DO,DIC,DINUM S DIC="^SCTM(404.46,",DLAYGO=404.46,DIC(0)="L"
  1.  . S X="1.2.2.0",DIC("DR")=".02///1;.03///3000412"
  1.  . D FILE^DICN
  1.  . I Y<1 K X S X="PCMM Client Patch File Error!" D MES^XPDUTL(.X)
  1.  ;
  1.  S BDGC=$O(^SCTM(404.46,"B","1.2.2.0",0)) Q:'BDGC
  1.  ;
  1.  I '$D(^SCTM(404.45,"B","1.2.2.0",1)) D   ;pcmm server patch
  1.  . K DD,DO,DIC,DINUM S DIC="^SCTM(404.45,",DLAYGO=404.45,DIC(0)="L"
  1.  . S X="SD*5.3*204",DIC("DR")=".02///"_BDGC_";.03///3000412;.04///1"
  1.  . D FILE^DICN
  1.  . I Y<1 K X S X="PCMM Server Patch File Error!" D MES^XPDUTL(.X)
  1.  ;
  1.  K X S X=$$REPEAT^XLFSTR(" ",20)_"Done" D MES^XPDUTL(.X)
  1.  ;
  1.  ;IHS/ITSC/LJF 4/9/2004 added subroutine below
  1. CANCEL ;EP; inactivate old Cancellaton Reason "SHERI"
  1.  NEW DIE,DA,DR
  1.  S DA=$O(^SD(409.2,"B","SHERI",0)) Q:'DA
  1.  S DIE=409.2,DR="4///INACTIVE" D ^DIE
  1.  Q