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

BDGPOST2.m

Go to the documentation of this file. 
  1. BDGPOST2 ; IHS/ANMC/LJF - ADT POSTINIT CONT. ;  [ 04/17/2003  2:09 PM ]
  1.  ;;5.3;PIMS;**1003**;MAY 28, 2004
  1.  ;;IHS/ITSC/LJF 04/06/2005 PATCH 1003 added 3 BTS protocol names to end of routine
  1.  ;                                    documenting sequence number assignments
  1.  ;
  1.  Q
  1.  ;
  1. SIDNR ;EP;delete all SI/DNR designations for patients not current inpatients
  1.  ; PIMS will remove designation upon discharge; old version did not
  1.  D BMES^XPDUTL("Removing Seriously Ill status if not a current inpatient...")
  1.  NEW COND,IEN
  1.  S COND=0 F  S COND=$O(^DPT("AS",COND)) Q:COND=""  D
  1.  . S IEN=0 F  S IEN=$O(^DPT("AS",COND,IEN)) Q:'IEN  D
  1.  .. I '$D(^DPT(IEN,.1)) K ^DPT(IEN,"DAC"),^DPT("AS",COND,IEN)
  1.  K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)
  1.  Q
  1.  ;
  1. DGPM ;EP; moves fields around in file 405
  1.  ; old admitting .08 now moved to 9999999.02
  1.  ; .08 now primary copied from attending .19
  1.  ; visit was 9999999.1 now .27
  1.  ; build AAP xref on field .19 attending provider
  1.  ; Using //// to bypass input transforms to speed up process
  1.  Q:$D(^BDGX(11))    ;conversion already run
  1.  D BMES^XPDUTL("Moving Patient Movement fields to new locations...")
  1.  ;
  1.  NEW IEN,ADM,ATT,VST,DR,DIE,DA,DIK
  1.  S IEN=0 F  S IEN=$O(^DGPM(IEN)) Q:'IEN  D
  1.  . Q:$G(^DGPM(IEN,0))=""            ;bad entry
  1.  . S ADM=$P(^DGPM(IEN,0),U,8)                ;old admitting prov field
  1.  . S ATT=$P(^DGPM(IEN,0),U,19)               ;attending provider
  1.  . S VST=$P($G(^DGPM(IEN,"IHS")),U)          ;old visit field
  1.  . I (ADM=""),(ATT=""),(VST="") Q            ;nothing to move/copy
  1.  . ;
  1.  . ; check validity of data
  1.  . I ATT,'$D(^VA(200,+ATT,0)) S ^BDGX(11,IEN,"ATT")=ATT,ATT=""
  1.  . I ADM,'$D(^VA(200,+ADM,0)) S ^BDGX(11,IEN,"ADM")=ADM,ADM=""
  1.  . I VST,'$D(^AUPNVSIT(+VST,0)) S ^BDGX(11,IEN,"VST")=VST,VST=""
  1.  . I VST,$P($G(^AUPNVSIT(+VST,0)),U,11)=1 S ^BDGX(11,IEN,"VSTDEL")=VST,VST=""
  1.  . ;
  1.  . S DR="" I ATT S DR=".08////"_ATT
  1.  . I ADM S DR=DR_$S(DR]"":";",1:"")_"9999999.02////"_ADM
  1.  . ;IHS/ITSC/WAR 4/17/03 P62 - concatenation of field needed
  1.  . ;I ('ATT),ADM S DR=$S(DR]"":";",1:"")_".19////"_ADM
  1.  . I ('ATT),ADM S DR=DR_$S(DR]"":";",1:"")_".19////"_ADM
  1.  . I VST S DR=DR_$S(DR]"":";",1:"")_".27////"_VST
  1.  . Q:DR=""  S DIE="^DGPM(",DA=IEN D ^DIE
  1.  ;
  1.  I $O(^BDGX(11,0)) K X S X="See ^BDGX(11 global for errors." D MES^XPDUTL(.X)
  1.  ;
  1.  ; run AAP xref - set .1041 field in DPT for current inpatients
  1.  K X S X="  Now indexing Attending Physician (AAP xref) for current inpatients." D MES^XPDUTL(.X)
  1.  NEW WARD,IEN,DA,DGPMDDF,DGPMDDT
  1.  S WARD=0 F  S WARD=$O(^DGPM("CN",WARD)) Q:WARD=""  D
  1.  . S IEN=0 F  S IEN=$O(^DGPM("CN",WARD,IEN)) Q:'IEN  D
  1.  .. S DA=IEN,DGPMDDF=19,DGPMDDT=1 D ^DGPMDDCN
  1.  ;
  1.  K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)
  1.  Q
  1.  ;
  1. WARD ;EP; copy IHS ward fields to new file
  1.  ; ^DIC(42,IHS* -> ^BDGWD(
  1.  ; will keep old data in file 42 until future patch
  1.  ;
  1.  Q:$O(^BDGWD(0))             ;already data in file
  1.  D BMES^XPDUTL("Copying IHS ward fields to new file...")
  1.  ;
  1.  NEW WRD,DATA,I,DIK,INA
  1.  S WRD=0 F  S WRD=$O(^DIC(42,WRD)) Q:'WRD  D
  1.  . S INA=$P($G(^DIC(42,WRD,"IHS")),U,4) Q:INA=2  ;don't copy deleted wd
  1.  . ;
  1.  . ; add new entry; update zero node of file
  1.  . S ^BDGWD(WRD,0)=WRD_U_$E($P(^DIC(42,WRD,0),U),1,5)
  1.  . S $P(^BDGWD(WRD,0),U,3)=$S(INA=1:"I",INA=0:"A",1:"")  ;active?
  1.  . S $P(^BDGWD(0),U,3)=WRD,$P(^BDGWD(0),U,4)=$P(^BDGWD(0),U,4)+1
  1.  . ;
  1.  . ; copy data items to new locations
  1.  . S ^BDGWD(WRD,1)=$G(^DIC(42,WRD,"IHS"))   ;copies pieces 1 - 5
  1.  . S $P(^BDGWD(WRD,1),U,4)=""               ;no 4th piece in new file
  1.  . S X=$P(^BDGWD(WRD,1),U),$P(^BDGWD(WRD,1),U)=$S(X="Y":1,1:0)  ;reset
  1.  . S DATA=$G(^DIC(42,WRD,"IHS1"))
  1.  . F I=1:1:9 S $P(^BDGWD(WRD,1),U,(I+10))=$P(DATA,U,I)  ;rest of items
  1.  ;
  1.  S DIK="^BDGWD(" D IXALL^DIK
  1.  K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)
  1.  Q
  1.  ;
  1. SCHVST ;EP; copy Scheduled Visit entries to new file
  1.  ; copy ^ADGAUTH -> ^BDGSV(
  1.  ; old data will be kept until future patch
  1.  ;
  1.  Q:$O(^BDGSV(0))                ;already has data
  1.  D BMES^XPDUTL("Copying Scheduled Visit entries to new file...")
  1.  ;
  1.  NEW OLD,OLD1,NEW,DATA,DFN,I,DIK
  1.  S OLD=0 F  S OLD=$O(^ADGAUTH(OLD)) Q:'OLD  D
  1.  . S DFN=$G(^ADGAUTH(OLD,0)) Q:'DFN    ;bad entry
  1.  . S OLD1=0 F  S OLD1=$O(^ADGAUTH(OLD,1,OLD1)) Q:'OLD1  D
  1.  .. S DATA=$G(^ADGAUTH(OLD,1,OLD1,0)) Q:DATA=""   ;bad entry
  1.  .. ;
  1.  .. ; add new entry
  1.  .. S NEW=$G(NEW)+1,^BDGSV(NEW,0)=DFN,^BDGSV(NEW,2)=""
  1.  .. S $P(^BDGSV(0),U,3)=NEW,$P(^BDGSV(0),U,4)=$P(^BDGSV(0),U,4)+1
  1.  .. ;
  1.  .. ; copy data items to new locations
  1.  .. F I="1;2","2;4","3;8","4;6","5;3","6;13","7;9","8;14","12;11" D
  1.  ... S $P(^BDGSV(NEW,0),U,$P(I,";",2))=$P(DATA,U,+I)
  1.  .. ;
  1.  .. I $P(DATA,U,13)="Y" S ^BDGSV(NEW,1)="RT"
  1.  .. ;
  1.  .. F I="9;1","10;3","14;2" D
  1.  ... S $P(^BDGSV(NEW,2),U,$P(I,";",2))=$P(DATA,U,+I)
  1.  .. ;
  1.  .. ; convert type of visit
  1.  .. I $P(^BDGSV(NEW,0),U,3)="I" S $P(^BDGSV(NEW,0),U,3)="A"
  1.  .. I $P(^BDGSV(NEW,0),U,3)="Q" S $P(^BDGSV(NEW,0),U,3)="O"
  1.  ;
  1.  S DIK="^BDGSV(" D IXALL^DIK
  1.  K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)
  1.  Q
  1.  ;
  1. EVENT ;EP; build event driver menu based on protocols installed
  1.  ; If you have the following installed, I will add them to event driver
  1.  ;
  1.  D BMES^XPDUTL("Building ADT Event Driver...")
  1.  NEW IEN,ITEM,BDGE
  1.  S BDGE=$O(^ORD(101,"B","BDGPM MOVEMENT EVENTS",0)) I 'BDGE D EVQ Q
  1.  ;
  1.  ; loop thru list of known protocols
  1.  ;F BDGI=1:1:13 S ITEM=$P($T(PROT+BDGI),";;",2) D
  1.  F BDGI=1:1:14 S ITEM=$P($T(PROT+BDGI),";;",2) D    ;PATCH #1001
  1.  . I $D(^ORD(101,"B",ITEM)) D         ;if protocol exists
  1.  .. S IEN=$O(^ORD(101,"B",ITEM,0)) Q:'IEN
  1.  .. Q:$D(^ORD(101,BDGE,10,"B",IEN))   ;already added to event driver
  1.  .. ;
  1.  .. ; go ahead and add it
  1.  .. S DIC="^ORD(101,"_BDGE_",10,",DIC(0)="L",DLAYGO=101.01
  1.  .. S DA(1)=BDGE,DIC("P")="101.01PA",X=IEN
  1.  .. S DIC("DR")="3///"_$P($T(PROT+BDGI),";;",3)
  1.  .. K DD,DO D FILE^DICN
  1.  K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)
  1.  ;
  1. EVQ ; call Scheduling event driver update
  1.  D EVENT^BSDPOST
  1.  Q
  1.  ;
  1. PROT ;; Protocols to add to event driver
  1.  ;;ORU PATIENT MOVMT;;101;;
  1.  ;;ORU AUTOLIST;;105;;
  1.  ;;PSJ OR PAT ADT;;120;;
  1.  ;;GMRADGPM MARK CHART;;210;;
  1.  ;;AQAL ADT EVENT;;150;;
  1.  ;;FHWMAS;;160;;
  1.  ;;SR IHS EVENT-ADMIT;;170;;
  1.  ;;MAGD DHCP-PACS ADT EVENTS;;180;;
  1.  ;;VEFSP PYXIS;;140;;
  1.  ;;AMCO ADT EVENT;;130;;
  1.  ;;BHL ADMIT A PATIENT;;5;;
  1.  ;;BHL TRANSFER A PATIENT;;6;;
  1.  ;;BHL DISCHARGE A PATIENT;;7;;
  1.  ;;BHL PYXIS ADT;;141;;
  1.  ;;BTS ADMIT A PATIENT (3M HDM);;102;;
  1.  ;;BTS DISCHARGE A PATIENT (3M HDM);;103;;
  1.  ;;BTS TRANSFER A PATIENT (3M HDM);;104;;