BSDP13PS.m

BSDP13PS ;cmi/anch/maw - PIMS Patch 1013 Post Init 2/27/2007 10:32:52 AM

 ;;5.3;PIMS;**1013**;FEB 27,2007;

 ;

 ;

 ;

 ;

ENV ;--environment check

 I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0

 I '$$INSTALLD("BJPC*2.0*5") D SORRY(2) Q

 I '$$INSTALLD("PIMS*5.3*1012") D SORRY(2) Q

 Q

 ;

EN ;EP - Post Init Entry Point

 D ADDTS("DAY SURGERY",23,"SURGERY SERVICE","DS")

 D ADDWL("W","WAIT LIST")

 D ADDPRT("BSDAM MENU WAIT LIST","BSDWL PRINT",6,60)

 D ADDMOPT("BSD MENU REPORTS","BSDRM LETTER TRACK BY PATIENT","LETT")

 D RM40971

 D XREFDAM

 Q

 ;

ADDTS(TS,CD,SS,ABB) ;-- add a new treating specialty

 Q:$O(^DIC(45.7,"B",TS,0))

 N FDA,FIENS,FERR,SERV

 S SERV=$O(^DIC(49,"B",SS,0))

 S FIENS="+1,"

 S FDA(45.7,FIENS,.01)=TS

 S FDA(45.7,FIENS,2)=SERV

 S FDA(45.7,FIENS,99)=ABB

 S FDA(45.7,FIENS,9999999.01)=CD

 D UPDATE^DIE("","FDA","FIENS","FERR(1)")

 Q

 ;

ADDWL(CODE,TEXT) ;-- add to waiting list file

 Q:$O(^VA(407.6,"B",CODE,0))

 N FDA,FIENS,FERR

 S FIENS="+1,"

 S FDA(407.6,FIENS,.01)=CODE

 S FDA(407.6,FIENS,1)=TEXT

 D UPDATE^DIE("","FDA","FIENS","FERR(1)")

 Q

 ;

ADDPRT(PROT,PROTA,MN,SQ) ;-- add an entry to the protocol file

 N PROTB,PROTB

 S PROTB=$O(^ORD(101,"B",PROT,0))

 S PROTC=$O(^ORD(101,"B",PROTA,0))

 Q:'PROTB

 Q:'PROTC

 N FDA,FIENS,FERR

 S FIENS="?+2,"_PROTB_","

 S FDA(101.01,FIENS,.01)=PROTC

 S FDA(101.01,FIENS,2)=MN

 S FDA(101.01,FIENS,3)=SQ

 D UPDATE^DIE("","FDA","FIENS","FERR(1)")

 I $D(FERR(1)) W !,"Error adding "_PROTA_" to the Item Multiple of Protocol "_PROT

 Q

 ;

ADDMOPT(MENU,OPT,MNE) ;-- add the menu option to the menu

 N X

 S X=$$ADD^XPDMENU(MENU,OPT,MNE)

 Q

 ;

RM40971 ;-- remove 409.71 from dictionary

 K ^DIC(409.71,0)

 K ^SD(409.71,0)

 Q

 ;

XREFDAM ;-- need to go through each clinic and appt and set date appointment made

 W !,"Now setting AIHSDAM cross reference for Date Appointment Made"

 N BSDC,BSDP,BSDD,BSDAM

 S BSDC=0 F  S BSDC=$O(^SC(BSDC)) Q:'BSDC  D

 . S BSDD=3091231 F  S BSDD=$O(^SC(BSDC,"S",BSDD)) Q:'BSDD  D

 .. S BSDP=0 F  S BSDP=$O(^SC(BSDC,"S",BSDD,1,BSDP)) Q:'BSDP  D

 ... S BSDAM=$P($G(^SC(BSDC,"S",BSDD,1,BSDP,0)),U,7)

 ... Q:'BSDAM

 ... W "."

 ... D XREFC^BSDDAM(BSDC,BSDD,BSDP)

 Q

 ;

INSTALLD(BSDSTAL) ;EP - Determine if patch BJPCSTAL was installed, where

 ; APCLSTAL is the name of the INSTALL.  E.g "AG*6.0*11".

 ;

 NEW BSDY,DIC,X,Y

 S X=$P(BSDSTAL,"*",1)

 S DIC="^DIC(9.4,",DIC(0)="FM",D="C"

 D IX^DIC

 I Y<1 D IMES Q 0

 S DIC=DIC_+Y_",22,",X=$P(BSDSTAL,"*",2)

 D ^DIC

 I Y<1 D IMES Q 0

 S DIC=DIC_+Y_",""PAH"",",X=$P(BSDSTAL,"*",3)

 D ^DIC

 S BSDY=Y

 D IMES

 Q $S(BSDY<1:0,1:1)

IMES ;

 D MES^XPDUTL($$CJ^XLFSTR("Patch """_BSDSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" installed.",IOM))

 Q

SORRY(X) ;

 KILL DIFQ

 I X=3 S XPDQUIT=2 Q

 S XPDQUIT=X

 W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)

 Q

 ;

BSDP13PS  ;cmi/anch/maw - PIMS Patch 1013 Post Init 2/27/2007 10:32:52 AM

 +1       ;;5.3;PIMS;**1013**;FEB 27,2007;

 +2       ;

 +3       ;

 +4       ;

 +5       ;

ENV       ;--environment check

 +1        IF $GET(XPDENV)=1

               SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 +2        FOR X="XPO1","XPZ1","XPZ2","XPI1"

               SET XPDDIQ(X)=0

 +3        IF '$$INSTALLD("BJPC*2.0*5")

               DO SORRY(2)

               QUIT 

 +4        IF '$$INSTALLD("PIMS*5.3*1012")

               DO SORRY(2)

               QUIT 

 +5        QUIT 

 +6       ;

EN        ;EP - Post Init Entry Point

 +1        DO ADDTS("DAY SURGERY",23,"SURGERY SERVICE","DS")

 +2        DO ADDWL("W","WAIT LIST")

 +3        DO ADDPRT("BSDAM MENU WAIT LIST","BSDWL PRINT",6,60)

 +4        DO ADDMOPT("BSD MENU REPORTS","BSDRM LETTER TRACK BY PATIENT","LETT")

 +5        DO RM40971

 +6        DO XREFDAM

 +7        QUIT 

 +8       ;

ADDTS(TS,CD,SS,ABB) ;-- add a new treating specialty

 +1        IF $ORDER(^DIC(45.7,"B",TS,0))

               QUIT 

 +2        NEW FDA,FIENS,FERR,SERV

 +3        SET SERV=$ORDER(^DIC(49,"B",SS,0))

 +4        SET FIENS="+1,"

 +5        SET FDA(45.7,FIENS,.01)=TS

 +6        SET FDA(45.7,FIENS,2)=SERV

 +7        SET FDA(45.7,FIENS,99)=ABB

 +8        SET FDA(45.7,FIENS,9999999.01)=CD

 +9        DO UPDATE^DIE("","FDA","FIENS","FERR(1)")

 +10       QUIT 

 +11      ;

ADDWL(CODE,TEXT) ;-- add to waiting list file

 +1        IF $ORDER(^VA(407.6,"B",CODE,0))

               QUIT 

 +2        NEW FDA,FIENS,FERR

 +3        SET FIENS="+1,"

 +4        SET FDA(407.6,FIENS,.01)=CODE

 +5        SET FDA(407.6,FIENS,1)=TEXT

 +6        DO UPDATE^DIE("","FDA","FIENS","FERR(1)")

 +7        QUIT 

 +8       ;

ADDPRT(PROT,PROTA,MN,SQ) ;-- add an entry to the protocol file

 +1        NEW PROTB,PROTB

 +2        SET PROTB=$ORDER(^ORD(101,"B",PROT,0))

 +3        SET PROTC=$ORDER(^ORD(101,"B",PROTA,0))

 +4        IF 'PROTB

               QUIT 

 +5        IF 'PROTC

               QUIT 

 +6        NEW FDA,FIENS,FERR

 +7        SET FIENS="?+2,"_PROTB_","

 +8        SET FDA(101.01,FIENS,.01)=PROTC

 +9        SET FDA(101.01,FIENS,2)=MN

 +10       SET FDA(101.01,FIENS,3)=SQ

 +11       DO UPDATE^DIE("","FDA","FIENS","FERR(1)")

 +12       IF $DATA(FERR(1))

               WRITE !,"Error adding "_PROTA_" to the Item Multiple of Protocol "_PROT

 +13       QUIT 

 +14      ;

ADDMOPT(MENU,OPT,MNE) ;-- add the menu option to the menu

 +1        NEW X

 +2        SET X=$$ADD^XPDMENU(MENU,OPT,MNE)

 +3        QUIT 

 +4       ;

RM40971   ;-- remove 409.71 from dictionary

 +1        KILL ^DIC(409.71,0)

 +2        KILL ^SD(409.71,0)

 +3        QUIT 

 +4       ;

XREFDAM   ;-- need to go through each clinic and appt and set date appointment made

 +1        WRITE !,"Now setting AIHSDAM cross reference for Date Appointment Made"

 +2        NEW BSDC,BSDP,BSDD,BSDAM

 +3        SET BSDC=0

           FOR 

               SET BSDC=$ORDER(^SC(BSDC))

               IF 'BSDC

                   QUIT 

               Begin DoDot:1

 +4                SET BSDD=3091231

                   FOR 

                       SET BSDD=$ORDER(^SC(BSDC,"S",BSDD))

                       IF 'BSDD

                           QUIT 

                       Begin DoDot:2

 +5                        SET BSDP=0

                           FOR 

                               SET BSDP=$ORDER(^SC(BSDC,"S",BSDD,1,BSDP))

                               IF 'BSDP

                                   QUIT 

                               Begin DoDot:3

 +6                                SET BSDAM=$PIECE($GET(^SC(BSDC,"S",BSDD,1,BSDP,0)),U,7)

 +7                                IF 'BSDAM

                                       QUIT 

 +8                                WRITE "."

 +9                                DO XREFC^BSDDAM(BSDC,BSDD,BSDP)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +10       QUIT 

 +11      ;

INSTALLD(BSDSTAL) ;EP - Determine if patch BJPCSTAL was installed, where

 +1       ; APCLSTAL is the name of the INSTALL.  E.g "AG*6.0*11".

 +2       ;

 +3        NEW BSDY,DIC,X,Y

 +4        SET X=$PIECE(BSDSTAL,"*",1)

 +5        SET DIC="^DIC(9.4,"

           SET DIC(0)="FM"

           SET D="C"

 +6        DO IX^DIC

 +7        IF Y<1

               DO IMES

               QUIT 0

 +8        SET DIC=DIC_+Y_",22,"

           SET X=$PIECE(BSDSTAL,"*",2)

 +9        DO ^DIC

 +10       IF Y<1

               DO IMES

               QUIT 0

 +11       SET DIC=DIC_+Y_",""PAH"","

           SET X=$PIECE(BSDSTAL,"*",3)

 +12       DO ^DIC

 +13       SET BSDY=Y

 +14       DO IMES

 +15       QUIT $SELECT(BSDY<1:0,1:1)

IMES      ;

 +1        DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BSDSTAL_""" is"_$SELECT(Y<1:" *NOT*",1:"")_" installed.",IOM))

 +2        QUIT 

SORRY(X)  ;

 +1        KILL DIFQ

 +2        IF X=3

               SET XPDQUIT=2

               QUIT 

 +3        SET XPDQUIT=X

 +4        WRITE *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)

 +5        QUIT 

 +6       ;