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 ;
