BSDPOST ; IHS/ANMC/LJF - PIMS POSTINIT ; [ 08/24/2004 11:32 AM ]
;;5.3;PIMS;**1001,1003,1004,1005**;MAY 28, 2004
; post init code for Scheduling data
;;IHS/ITSC/LJF 04/14/2005 PATCH 1003 added 1 BTS protocol name to end of routine
; 06/23/2005 PATCH 1003 added 1 APCH protocol name to end of routine
; 08/24/2005 PATCH 1004 added 4 BSDX (GUI Scheduling) protocols
;IHS/OIT/LJF 02/16/2006 PATCH 1005 added new BSDAM RS AT CHECKIN to protocol list
; (documenting sequence number assignments)
;
Q
;IHS/ITSC/WAR 8/21/03 new Xref coming in w/Pkg, now need to
ASTOP ;EP; -- reindex existing records for historic visits in EHR
S DIK="^SC("
S DIK(1)="8^ASTOP"
D ENALL^DIK
Q
;
;IHS/ITSC/WAR 10/17/03 added - updates the Sched ver# in pkg file
;IHS/ITSC/LJF 1/16/2004 added more updates
PKGFILE ;EP
NEW VER,BDGV,BDGN,X,DA,DIC,Y,DIE,DR
I $D(XPDNM) S VER=$$VER^XPDUTL(XPDNM)
I $G(VER)]"" D
.; update current version field
.S BDGN=$O(^DIC(9.4,"C","SD",0)) Q:'BDGN
.S ^DIC(9.4,BDGN,"VERSION")=VER
.;
.; clean up old 5.3 test versions
.S BDGV=0 F S BDGV=$O(^DIC(9.4,BDGN,22,"B",BDGV)) Q:BDGV="" D
..I BDGV["5.3",BDGV'=5.3 D
...S DIE="^DIC(9.4,"_BDGN_",22,",DA(1)=BDGN,DR=".01///@"
...S DA=$O(^DIC(9.4,BDGN,22,"B",BDGV,0)) Q:'DA
...D ^DIE
.;
.; now add version multiple without test version #
.S DIC="^DIC(9.4,"_BDGN_",22,",DIC(0)="L",X=5.3
.S DIC("P")=$P(^DD(9.4,22,0),U,2)
.S DIC("DR")="2///"_DT_";3///`"_DUZ,DA(1)=BDGN
.D ^DIC
;
D PATCHES^BSDPOST2 ;add patch history
Q
;
AIHSDAM ;EP; -- creates xref AIHSDAM upon installation
;IHS/ITSC/WAR 8/19/2004 PATCH #1001 Next line REMd to allow a call
; to this tag (from PATCH 1001 post-init rtn) to make sure every
; site has run this sub-rtn w/o a problem. See 16^BDGPOST...
; ^BDGPOST(16) has already been set by another process. Next line
; was REMd for the above mentioned reason.
;Q:$D(^BDGX(16)) ;already done
D BMES^XPDUTL("Creating AIHSDAM cross-reference on file 44...")
;
NEW CLIN,DATE,PAT,MADE
K ^SC("AIHSDAM")
S CLIN=0 F S CLIN=$O(^SC(CLIN)) Q:'CLIN D
. S DATE=2991000 F S DATE=$O(^SC(CLIN,"S",DATE)) Q:'DATE D
.. I '$D(ZTQUEUED) W "."
.. S PAT=0 F S PAT=$O(^SC(CLIN,"S",DATE,1,PAT)) Q:'PAT D
... S MADE=$P($G(^SC(CLIN,"S",DATE,1,PAT,0)),U,7)
... I MADE]"" S ^SC("AIHSDAM",CLIN,MADE,DATE,PAT)=""
K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)
Q
;
LETTER ;EP; create Appointment Slip letter
Q:$D(^VA(407.5,"B","APPOINTMENT SLIP")) ;already in file
D BMES^XPDUTL("Creating Appointment Slip Letter...")
;
NEW IEN,DIC,DLAYGO,DD,DO,X,Y
S DIC="^VA(407.5,",DLAYGO=407.5,DIC(0)="L",X="APPOINTMENT SLIP"
S DIC("DR")="1///P;9999999.01///1"
K DD,DO D FILE^DICN
I Y<1 K X S X=" ***> Could not create letter; will need to be added manually" D MES^XPDUTL(.X) Q
;
; now add default text
S IEN=+Y,^VA(407.5,IEN,1,0)="^407.52^1^1"
S ^VA(407.5,IEN,1,1,0)=" Your next appointment in our clinic is as follows:"
S ^VA(407.5,IEN,2,0)="^407.53^1^1"
S ^VA(407.5,IEN,2,1,0)="To reschedule any appointments listed, please call our main appointment desk at XXX-XXXX."
;
K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)
Q
;
MERG ;EP; Change Scheduling Merge routine in Package file
NEW DIE,DA,DR,PKG,IEN
D BMES^XPDUTL("Updating Merge routine for Scheduling...")
;
; find package entry
S PKG=$O(^DIC(9.4,"C","SD",0)) I 'PKG D MRGERR Q
; find entry under Files Affected
S IEN=$O(^DIC(9.4,PKG,20,0)) I 'IEN D MRGERR Q
; make sure entry if so file 2 (^DPT)
I $P($G(^DIC(9.4,PKG,20,IEN,0)),U)'=2 D MRGERR Q
;
; now update entry
S DIE="^DIC(9.4,"_PKG_",20,",DA(1)=PKG,DA=IEN,DR="3///BSDMERG" D ^DIE
K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)
Q
;
MRGERR ; process error message for package merge update
K X S X=$$SP(10)_"Cannot find SD Package; update manually."
D MES^XPDUTL(.X)
Q
;
CLINIC ;EP; copy clinic parameters to new locations
; IHS fields that used to be in file 44 are now in 9009017.2
;
Q:$D(^BDGX(2)) ;already done
D BMES^XPDUTL("Copying IHS fields for each active clinic to new file...")
NEW CLN,OLD,NODE,X,Y,Z
S CLN=0 F S CLN=$O(^SC(CLN)) Q:'CLN D
. ;
. Q:'$$ACTV^BSDU(CLN,DT) ;quit if not currently active
. ;
. ; stuff "ask check-in/check-out time to YES
. NEW DIE,DA,DR
. S DIE=44,DA=CLN,DR="24///1" D ^DIE
. ;
. ; if entry not in new file, add it
. I '$D(^BSDSC(CLN)) D I Y<1 Q
.. NEW DIC,DLAYGO,X,DINUM,DD,DO
.. S DIC="^BSDSC(",DLAYGO=9009017.2,(X,DINUM)=CLN,DIC(0)="L"
.. D FILE^DICN
. ;
. ; now copy fields
. S OLD=$G(^SC(CLN,9999999)) Q:OLD="" ;quit if no data
. ;
. ; move fields to new file and new piece
. F NODE="2^5","6^3","7^2","9^9","13^8","14^13","15^14" D
.. S $P(^BSDSC(CLN,0),U,$P(NODE,U,2))=$P(OLD,U,+NODE)
. ;
. ; 2 fields need set of codes converted Y/N to 1/0
. I $P(OLD,U)]"" S $P(^BSDSC(CLN,0),U,4)=$S($P(OLD,U)="Y":1,1:0)
. I $P(OLD,U,4)]"" S $P(^BSDSC(CLN,0),U,7)=$S($P(OLD,U,4)="Y":1,1:0)
. ;
. ; merge med profile & apro into one new field
. ;IHS/ITSC/WAR 2/3/04 need to init Z each time for "",0 and "N"
. S Z=0
. S X=$P(OLD,U,3),Y=$P($G(^SC(CLN,"PS")),U)
. ;
. ;IHS/ITSC/LJF 4/21/2004 old field had 0=yes; 1=no
. ;I (X="Y"),(Y=1) S Z=3 ;both
. ;I (X="Y"),(Y'=1) S Z=1 ;med profile only
. ;I (X'="Y"),(Y=1) S Z=2 ;action profile only
. I (X="Y"),(Y=0) S Z=3 ;both
. I (X="Y"),(Y'=0) S Z=1 ;med profile only
. I (X'="Y"),(Y=0) S Z=2 ;action profile only
. ;
. S $P(^BSDSC(CLN,0),U,6)=$S($G(Z):Z,1:0)
. ;
. ; move default visit provider to provider multiple
. S X=$P(OLD,U,8) I X,'$D(^SC(CLN,"PR","B",X)) D
.. NEW DIC,DLAYGO,DA
.. S DIC="^SC("_CLN_",""PR"",",DIC(0)="L",X="`"_X,DA(1)=CLN
.. S DIC("DR")=".02///1",DIC("P")="44.1P" D ^DIC
. ;
. ; copy overbook users
. S OVB=0 F S OVB=$O(^SC(CLN,"IHS OB",OVB)) Q:'OVB D
.. S NODE=$G(^SC(CLN,"IHS OB",OVB,0)) Q:NODE=""
.. Q:$D(^BSDSC(CLN,1,"B",+NODE)) ;already there
.. NEW DIC,DLAYGO,X,DA
.. S DIC="^BSDSC("_CLN_",1,",DIC("P")="9009017.21P",DA(1)=CLN
.. S DIC(0)="L",X="`"_(+NODE),DIC("DR")=".02///"_$P(NODE,U,2)
.. D ^DIC
;
; reindex new file
K X S X=" Reindexing new Cllinic Setup file..." D MES^XPDUTL(.X)
NEW DIK S DIK="^BSDSC(" 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
; Called by EVENT^BSDPOST2 after ADT event driver updated
;
D BMES^XPDUTL("Building Scheduling Event Driver...")
NEW IEN,ITEM,BSDE
S BSDE=$O(^ORD(101,"B","BSDAM APPOINTMENT EVENTS",0)) Q:'BSDE
;
; loop thru list of known protocols
F BSDI=1:1:2 S ITEM=$P($T(PROT+BSDI),";;",2) D
. I $D(^ORD(101,"B",ITEM)) D ;if protocol exists
.. S IEN=$O(^ORD(101,"B",ITEM,0)) Q:'IEN
.. Q:$D(^ORD(101,BSDE,10,"B",IEN)) ;already added to event driver
.. ;
.. ; go ahead and add it
.. S DIC="^ORD(101,"_BSDE_",10,",DIC(0)="L",DLAYGO=101.01
.. S DA(1)=BSDE,DIC("P")="101.01PA",X=IEN
.. S DIC("DR")="3///"_$P($T(PROT+BSDI),";;",3)
.. K DD,DO D FILE^DICN
K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)
Q
;
PAD(D,L) ;EP -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
;
PROT ;; Protocols to add to event driver
;;BHL PYXIS SCHEDULING;;12;;
;;VEN PRINT PCC+ ENCOUNTER FORM;;15;;
;;BTS SCHEDULE A PATIENT (3M HDM);;51;;
;;APCH CHECK-IN PRINT PAT HS;;31;;
;;BSDX ADD APPOINTMENT;;10.2;;
;;BSDX CANCEL APPOINTMENT;;10.4;;
;;BSDX CHECKIN APPOINTMENT;;10.6;;
;;BSDX NOSHOW APPOINTMENT;;10.8;;
;;BSDAM RS AT CHECKIN;;13;;
BSDPOST ; IHS/ANMC/LJF - PIMS POSTINIT ; [ 08/24/2004 11:32 AM ]
+1 ;;5.3;PIMS;**1001,1003,1004,1005**;MAY 28, 2004
+2 ; post init code for Scheduling data
+3 ;;IHS/ITSC/LJF 04/14/2005 PATCH 1003 added 1 BTS protocol name to end of routine
+4 ; 06/23/2005 PATCH 1003 added 1 APCH protocol name to end of routine
+5 ; 08/24/2005 PATCH 1004 added 4 BSDX (GUI Scheduling) protocols
+6 ;IHS/OIT/LJF 02/16/2006 PATCH 1005 added new BSDAM RS AT CHECKIN to protocol list
+7 ; (documenting sequence number assignments)
+8 ;
+9 QUIT
+10 ;IHS/ITSC/WAR 8/21/03 new Xref coming in w/Pkg, now need to
ASTOP ;EP; -- reindex existing records for historic visits in EHR
+1 SET DIK="^SC("
+2 SET DIK(1)="8^ASTOP"
+3 DO ENALL^DIK
+4 QUIT
+5 ;
+6 ;IHS/ITSC/WAR 10/17/03 added - updates the Sched ver# in pkg file
+7 ;IHS/ITSC/LJF 1/16/2004 added more updates
PKGFILE ;EP
+1 NEW VER,BDGV,BDGN,X,DA,DIC,Y,DIE,DR
+2 IF $DATA(XPDNM)
SET VER=$$VER^XPDUTL(XPDNM)
+3 IF $GET(VER)]""
Begin DoDot:1
+4 ; update current version field
+5 SET BDGN=$ORDER(^DIC(9.4,"C","SD",0))
IF 'BDGN
QUIT
+6 SET ^DIC(9.4,BDGN,"VERSION")=VER
+7 ;
+8 ; clean up old 5.3 test versions
+9 SET BDGV=0
FOR
SET BDGV=$ORDER(^DIC(9.4,BDGN,22,"B",BDGV))
IF BDGV=""
QUIT
Begin DoDot:2
+10 IF BDGV["5.3"
IF BDGV'=5.3
Begin DoDot:3
+11 SET DIE="^DIC(9.4,"_BDGN_",22,"
SET DA(1)=BDGN
SET DR=".01///@"
+12 SET DA=$ORDER(^DIC(9.4,BDGN,22,"B",BDGV,0))
IF 'DA
QUIT
+13 DO ^DIE
End DoDot:3
End DoDot:2
+14 ;
+15 ; now add version multiple without test version #
+16 SET DIC="^DIC(9.4,"_BDGN_",22,"
SET DIC(0)="L"
SET X=5.3
+17 SET DIC("P")=$PIECE(^DD(9.4,22,0),U,2)
+18 SET DIC("DR")="2///"_DT_";3///`"_DUZ
SET DA(1)=BDGN
+19 DO ^DIC
End DoDot:1
+20 ;
+21 ;add patch history
DO PATCHES^BSDPOST2
+22 QUIT
+23 ;
AIHSDAM ;EP; -- creates xref AIHSDAM upon installation
+1 ;IHS/ITSC/WAR 8/19/2004 PATCH #1001 Next line REMd to allow a call
+2 ; to this tag (from PATCH 1001 post-init rtn) to make sure every
+3 ; site has run this sub-rtn w/o a problem. See 16^BDGPOST...
+4 ; ^BDGPOST(16) has already been set by another process. Next line
+5 ; was REMd for the above mentioned reason.
+6 ;Q:$D(^BDGX(16)) ;already done
+7 DO BMES^XPDUTL("Creating AIHSDAM cross-reference on file 44...")
+8 ;
+9 NEW CLIN,DATE,PAT,MADE
+10 KILL ^SC("AIHSDAM")
+11 SET CLIN=0
FOR
SET CLIN=$ORDER(^SC(CLIN))
IF 'CLIN
QUIT
Begin DoDot:1
+12 SET DATE=2991000
FOR
SET DATE=$ORDER(^SC(CLIN,"S",DATE))
IF 'DATE
QUIT
Begin DoDot:2
+13 IF '$DATA(ZTQUEUED)
WRITE "."
+14 SET PAT=0
FOR
SET PAT=$ORDER(^SC(CLIN,"S",DATE,1,PAT))
IF 'PAT
QUIT
Begin DoDot:3
+15 SET MADE=$PIECE($GET(^SC(CLIN,"S",DATE,1,PAT,0)),U,7)
+16 IF MADE]""
SET ^SC("AIHSDAM",CLIN,MADE,DATE,PAT)=""
End DoDot:3
End DoDot:2
End DoDot:1
+17 KILL X
SET X=$$REPEAT^XLFSTR(" ",20)_"Done."
DO MES^XPDUTL(.X)
+18 QUIT
+19 ;
LETTER ;EP; create Appointment Slip letter
+1 ;already in file
IF $DATA(^VA(407.5,"B","APPOINTMENT SLIP"))
QUIT
+2 DO BMES^XPDUTL("Creating Appointment Slip Letter...")
+3 ;
+4 NEW IEN,DIC,DLAYGO,DD,DO,X,Y
+5 SET DIC="^VA(407.5,"
SET DLAYGO=407.5
SET DIC(0)="L"
SET X="APPOINTMENT SLIP"
+6 SET DIC("DR")="1///P;9999999.01///1"
+7 KILL DD,DO
DO FILE^DICN
+8 IF Y<1
KILL X
SET X=" ***> Could not create letter; will need to be added manually"
DO MES^XPDUTL(.X)
QUIT
+9 ;
+10 ; now add default text
+11 SET IEN=+Y
SET ^VA(407.5,IEN,1,0)="^407.52^1^1"
+12 SET ^VA(407.5,IEN,1,1,0)=" Your next appointment in our clinic is as follows:"
+13 SET ^VA(407.5,IEN,2,0)="^407.53^1^1"
+14 SET ^VA(407.5,IEN,2,1,0)="To reschedule any appointments listed, please call our main appointment desk at XXX-XXXX."
+15 ;
+16 KILL X
SET X=$$REPEAT^XLFSTR(" ",20)_"Done."
DO MES^XPDUTL(.X)
+17 QUIT
+18 ;
MERG ;EP; Change Scheduling Merge routine in Package file
+1 NEW DIE,DA,DR,PKG,IEN
+2 DO BMES^XPDUTL("Updating Merge routine for Scheduling...")
+3 ;
+4 ; find package entry
+5 SET PKG=$ORDER(^DIC(9.4,"C","SD",0))
IF 'PKG
DO MRGERR
QUIT
+6 ; find entry under Files Affected
+7 SET IEN=$ORDER(^DIC(9.4,PKG,20,0))
IF 'IEN
DO MRGERR
QUIT
+8 ; make sure entry if so file 2 (^DPT)
+9 IF $PIECE($GET(^DIC(9.4,PKG,20,IEN,0)),U)'=2
DO MRGERR
QUIT
+10 ;
+11 ; now update entry
+12 SET DIE="^DIC(9.4,"_PKG_",20,"
SET DA(1)=PKG
SET DA=IEN
SET DR="3///BSDMERG"
DO ^DIE
+13 KILL X
SET X=$$REPEAT^XLFSTR(" ",20)_"Done."
DO MES^XPDUTL(.X)
+14 QUIT
+15 ;
MRGERR ; process error message for package merge update
+1 KILL X
SET X=$$SP(10)_"Cannot find SD Package; update manually."
+2 DO MES^XPDUTL(.X)
+3 QUIT
+4 ;
CLINIC ;EP; copy clinic parameters to new locations
+1 ; IHS fields that used to be in file 44 are now in 9009017.2
+2 ;
+3 ;already done
IF $DATA(^BDGX(2))
QUIT
+4 DO BMES^XPDUTL("Copying IHS fields for each active clinic to new file...")
+5 NEW CLN,OLD,NODE,X,Y,Z
+6 SET CLN=0
FOR
SET CLN=$ORDER(^SC(CLN))
IF 'CLN
QUIT
Begin DoDot:1
+7 ;
+8 ;quit if not currently active
IF '$$ACTV^BSDU(CLN,DT)
QUIT
+9 ;
+10 ; stuff "ask check-in/check-out time to YES
+11 NEW DIE,DA,DR
+12 SET DIE=44
SET DA=CLN
SET DR="24///1"
DO ^DIE
+13 ;
+14 ; if entry not in new file, add it
+15 IF '$DATA(^BSDSC(CLN))
Begin DoDot:2
+16 NEW DIC,DLAYGO,X,DINUM,DD,DO
+17 SET DIC="^BSDSC("
SET DLAYGO=9009017.2
SET (X,DINUM)=CLN
SET DIC(0)="L"
+18 DO FILE^DICN
End DoDot:2
IF Y<1
QUIT
+19 ;
+20 ; now copy fields
+21 ;quit if no data
SET OLD=$GET(^SC(CLN,9999999))
IF OLD=""
QUIT
+22 ;
+23 ; move fields to new file and new piece
+24 FOR NODE="2^5","6^3","7^2","9^9","13^8","14^13","15^14"
Begin DoDot:2
+25 SET $PIECE(^BSDSC(CLN,0),U,$PIECE(NODE,U,2))=$PIECE(OLD,U,+NODE)
End DoDot:2
+26 ;
+27 ; 2 fields need set of codes converted Y/N to 1/0
+28 IF $PIECE(OLD,U)]""
SET $PIECE(^BSDSC(CLN,0),U,4)=$SELECT($PIECE(OLD,U)="Y":1,1:0)
+29 IF $PIECE(OLD,U,4)]""
SET $PIECE(^BSDSC(CLN,0),U,7)=$SELECT($PIECE(OLD,U,4)="Y":1,1:0)
+30 ;
+31 ; merge med profile & apro into one new field
+32 ;IHS/ITSC/WAR 2/3/04 need to init Z each time for "",0 and "N"
+33 SET Z=0
+34 SET X=$PIECE(OLD,U,3)
SET Y=$PIECE($GET(^SC(CLN,"PS")),U)
+35 ;
+36 ;IHS/ITSC/LJF 4/21/2004 old field had 0=yes; 1=no
+37 ;I (X="Y"),(Y=1) S Z=3 ;both
+38 ;I (X="Y"),(Y'=1) S Z=1 ;med profile only
+39 ;I (X'="Y"),(Y=1) S Z=2 ;action profile only
+40 ;both
IF (X="Y")
IF (Y=0)
SET Z=3
+41 ;med profile only
IF (X="Y")
IF (Y'=0)
SET Z=1
+42 ;action profile only
IF (X'="Y")
IF (Y=0)
SET Z=2
+43 ;
+44 SET $PIECE(^BSDSC(CLN,0),U,6)=$SELECT($GET(Z):Z,1:0)
+45 ;
+46 ; move default visit provider to provider multiple
+47 SET X=$PIECE(OLD,U,8)
IF X
IF '$DATA(^SC(CLN,"PR","B",X))
Begin DoDot:2
+48 NEW DIC,DLAYGO,DA
+49 SET DIC="^SC("_CLN_",""PR"","
SET DIC(0)="L"
SET X="`"_X
SET DA(1)=CLN
+50 SET DIC("DR")=".02///1"
SET DIC("P")="44.1P"
DO ^DIC
End DoDot:2
+51 ;
+52 ; copy overbook users
+53 SET OVB=0
FOR
SET OVB=$ORDER(^SC(CLN,"IHS OB",OVB))
IF 'OVB
QUIT
Begin DoDot:2
+54 SET NODE=$GET(^SC(CLN,"IHS OB",OVB,0))
IF NODE=""
QUIT
+55 ;already there
IF $DATA(^BSDSC(CLN,1,"B",+NODE))
QUIT
+56 NEW DIC,DLAYGO,X,DA
+57 SET DIC="^BSDSC("_CLN_",1,"
SET DIC("P")="9009017.21P"
SET DA(1)=CLN
+58 SET DIC(0)="L"
SET X="`"_(+NODE)
SET DIC("DR")=".02///"_$PIECE(NODE,U,2)
+59 DO ^DIC
End DoDot:2
End DoDot:1
+60 ;
+61 ; reindex new file
+62 KILL X
SET X=" Reindexing new Cllinic Setup file..."
DO MES^XPDUTL(.X)
+63 NEW DIK
SET DIK="^BSDSC("
DO IXALL^DIK
+64 KILL X
SET X=$$REPEAT^XLFSTR(" ",20)_"Done."
DO MES^XPDUTL(.X)
+65 QUIT
+66 ;
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 ; Called by EVENT^BSDPOST2 after ADT event driver updated
+3 ;
+4 DO BMES^XPDUTL("Building Scheduling Event Driver...")
+5 NEW IEN,ITEM,BSDE
+6 SET BSDE=$ORDER(^ORD(101,"B","BSDAM APPOINTMENT EVENTS",0))
IF 'BSDE
QUIT
+7 ;
+8 ; loop thru list of known protocols
+9 FOR BSDI=1:1:2
SET ITEM=$PIECE($TEXT(PROT+BSDI),";;",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,BSDE,10,"B",IEN))
QUIT
+13 ;
+14 ; go ahead and add it
+15 SET DIC="^ORD(101,"_BSDE_",10,"
SET DIC(0)="L"
SET DLAYGO=101.01
+16 SET DA(1)=BSDE
SET DIC("P")="101.01PA"
SET X=IEN
+17 SET DIC("DR")="3///"_$PIECE($TEXT(PROT+BSDI),";;",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 QUIT
+21 ;
PAD(D,L) ;EP -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
+2 ;
PROT ;; Protocols to add to event driver
+1 ;;BHL PYXIS SCHEDULING;;12;;
+2 ;;VEN PRINT PCC+ ENCOUNTER FORM;;15;;
+3 ;;BTS SCHEDULE A PATIENT (3M HDM);;51;;
+4 ;;APCH CHECK-IN PRINT PAT HS;;31;;
+5 ;;BSDX ADD APPOINTMENT;;10.2;;
+6 ;;BSDX CANCEL APPOINTMENT;;10.4;;
+7 ;;BSDX CHECKIN APPOINTMENT;;10.6;;
+8 ;;BSDX NOSHOW APPOINTMENT;;10.8;;
+9 ;;BSDAM RS AT CHECKIN;;13;;
