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