BSDPOST.m

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;;