PSN513PO ;BIR/SJA-Post install routine for patch PSN*4*513 ; 19 Jan 2017 1:20 PM
;;4.0;NATIONAL DRUG FILE;**513**; 30 Oct 98;Build 53
;
Q
POST ; -- post-install entry
N II,PSNA,ITEM,PSNSVR1 S PSSMXUA2=1
; delete invalid hazard waste entries
S II=0 F S II=$O(^PSNDF(50.68,II)) Q:'II D
. I $G(^PSNDF(50.68,II,"HAZTODIS2",0))=0 K ^PSNDF(50.68,II,"HAZTODIS2",0)
;
D BMES^XPDUTL("Rebuilding National Drug File Menu....")
D ADD
D BMES^XPDUTL("Rebuilding menus complete.")
D PPSN
D SETWS
S PSNSVR1=$$FILESRVR("PPSN","vaausppsapp21.aac.domain.ext",443)
D SERVICE("UPDATE_STATUS","PPSN",PSNSVR1) ; add web service to web server
Q
;
ADD ; -- add new menu option and update order for PSNMGR & PSN PPS MENU
S PSNA=$$ADD^XPDMENU("PSNMGR","PSNPMIS PRINT","PMIS",9)
S PSNA=$$ADD^XPDMENU("PSNMGR","PSN MED GUIDE","FDA",10)
S PSNA=$$ADD^XPDMENU("PSNMGR","PSN PPS MENU","PPS",20)
D BMES^XPDUTL(" PSN PPS MENU option "_$S('+$G(PSNA):"NOT ",1:"")_"added to menu PSNMGR")
D BMES^XPDUTL("Updating PSN PPS MENU menu display order...")
S ITEM="PSN PPS SCHEDULE DOWNLOAD",PSNA=$$ADD^XPDMENU("PSN PPS MENU",ITEM,"SD",1) D MSG(ITEM,PSNA)
S ITEM="PSN PPS SCHEDULE INSTALL",PSNA=$$ADD^XPDMENU("PSN PPS MENU",ITEM,"SI",2)
S ITEM="PSN PPS MANUAL DOWNLOAD",PSNA=$$ADD^XPDMENU("PSN PPS MENU",ITEM,"MD",3)
S ITEM="PSN PPS MANUAL INSTALL",PSNA=$$ADD^XPDMENU("PSN PPS MENU",ITEM,"MI",4)
S ITEM="PSN PPS REJECT FILE",PSNA=$$ADD^XPDMENU("PSN PPS MENU",ITEM,"RJ",5)
S ITEM="PSN PPS PARAM",PSNA=$$ADD^XPDMENU("PSN PPS MENU",ITEM,"SP",6)
D MES^XPDUTL("Display order updated")
Q
MSG(ITEM,PSNA) ; -- write message
D BMES^XPDUTL(" "_ITEM_" option "_$S('+$G(PSNA):"NOT ",1:"")_"added to menu PSN PPS MENU")
Q
PPSN ; -- add new entry in ^PS(57.23 if it doesn't exist
Q:$O(^PS(57.23,0))
N PSNTN,RADD,RUSR
K DA,DIC S X="PPSN",DIC="^PS(57.23,",DIC(0)="L" D FILE^DICN K DIC
S PSNTN=+Y
S RADD="vaausmocftpprd01.aac.domain.ext",RUSR="presftp"
S DA=PSNTN,DIE=57.23,DR="2///0;8///0;9///N;10///N;20///"_RADD_";22///"_RUSR_";45///Y" D ^DIE K DR
S $P(^PS(59.7,1,10),"^",12)="P"
Q
;
SETWS ;define UPDATE_STATUS web service
N PSSWSERV,PSSWSER2,PPSWPPSN,PSSWSCNT,PSSWSMSG,PSSWSSTA,PSSWSERR,DA,DIE,DIC,DR,X,Y,DLAYGO,WSARR
S (PSSWSERR,PSSWSCNT)=0,PSSMXUA2=1
S DIC="^XOB(18.12,",X="PPSN",DIC(0)="X" D ^DIC
I Y<1 D
.D BMES^XPDUTL(" Creating PPSN web server.") S PSSMXUA2=PSSMXUA2+1
.S WSARR("WSDL FILE")=""
.S WSARR("CACHE PACKAGE NAME")=""
.S WSARR("WEB SERVICE NAME")="PPSN"
.S WSARR("AVAILABILITY RESOURCE")="?wsdl"
.S XOBSTAT=$$GENPORT^XOBWLIB(.WSARR)
.S DIC="^XOB(18.12,",X="PPSN",DIC(0)=X
S PPSWPPSN=+Y K DIC ;find the PPSN web server IEN
D BMES^XPDUTL("Beginning UPDATE_STATUS Web Service definition for PPSN web server: ")
S @XPDGREF@("PSSMLMSG",PSSMXUA2)="Beginning UPDATE_STATUS Web Service definition: " S PSSMXUA2=PSSMXUA2+1
I PPSWPPSN=-1 D G SETWSQT
.D BMES^XPDUTL(" PPSN Web Server is not defined. Please contact product support.") S PSSWSERR=1
.S @XPDGREF@("PSSMLMSG",PSSMXUA2)=" PPSN Web Server isn't defined and UPDATE_STATUS Web Service couldn't be" S PSSMXUA2=PSSMXUA2+1
.S @XPDGREF@("PSSMLMSG",PSSMXUA2)=" created. Please log a National Help Desk Ticket and refer to this message." S PSSMXUA2=PSSMXUA2+1
SETWS2 ;
S DIC="^XOB(18.02,",X="UPDATE_STATUS",DIC(0)="X" D ^DIC S PSSWSERV=+Y ;get the IEN for the UPDATE_STATUS web service
I +Y<1,PSSWSCNT=0 D REGREST^XOBWLIB("UPDATE_STATUS","/PRE/ndf/update/","status") H 3 S PSSWSCNT=1 G SETWS2 ;if not there register the web service
I +Y<1 D H 3 G SETWSQT
.D BMES^XPDUTL(" UPDATE_STATUS web service has NOT been created. Please contact product support.")
.S @XPDGREF@("PSSMLMSG",PSSMXUA2)=" UPDATE_STATUS web service has NOT been defined. Please log a" S PSSMXUA2=PSSMXUA2+1,PSSWSERR=1
.S @XPDGREF@("PSSMLMSG",PSSMXUA2)=" National Help Desk ticket and refer to this message." S PSSMXUA2=PSSMXUA2+1
.S @XPDGREF@("PSSMLMSG",PSSMXUA2)=" " S PSSMXUA2=PSSMXUA2+1
S PSSWSMSG=$S(PSSWSCNT=0:"UPDATE_STATUS web service was previously defined. No action taken.",1:"UPDATE_STATUS web service has been defined.")
S @XPDGREF@("PSSMLMSG",PSSMXUA2)=" "_PSSWSMSG S PSSMXUA2=PSSMXUA2+1
D BMES^XPDUTL(" "_PSSWSMSG)
;
K DIC,DIE,DA,DR,X,Y
S DIC="^XOB(18.12,"_PPSWPPSN_",100,",X="UPDATE_STATUS",DIC(0)="X" D ^DIC S PSSWSER2=+Y
L +^XOB(18.12,PPSWPPSN):20 I '$T D H 3 G SETWSQT
.D BMES^XPDUTL(" Unable to lock file 18.12 to enable UPDATE_STATUS web service. Please ")
.D BMES^XPDUTL(" contact product support.")
.S @XPDGREF@("PSSMLMSG",PSSMXUA2)=" Unable to lock file 18.12 to enable UPDATE_STATUS web service." S PSSMXUA2=PSSMXUA2+1
.S @XPDGREF@("PSSMLMSG",PSSMXUA2)=" Please contact the National Help Desk and refer to this message." S PSSMXUA2=PSSMXUA2+1,PSSWSERR=1
I PSSWSER2=-1 D PSSENABL G SETWSQT
S PSSWSSTA=$$GET1^DIQ(18.121,PSSWSER2_",1",".06","I")
I PSSWSSTA=-1 D PSSENABL G SETWSQT
I PSSWSSTA=""!(PSSWSSTA=0) D PSSENAB2 G SETWSQT
I PSSWSSTA D
.D BMES^XPDUTL(" UPDATE_STATUS web service was previously enabled. No action taken.")
.S @XPDGREF@("PSSMLMSG",PSSMXUA2)=" UPDATE_STATUS web service was previously enabled. No action taken." S PSSMXUA2=PSSMXUA2+1
SETWSQT ;
L -^XOB(18.12,PPSWPPSN)
I $G(PSSWSERR) D
.D BMES^XPDUTL(" **************************************************************************")
.D BMES^XPDUTL(" ** Due to error(s), UPDATE_STATUS web service definition is not complete. **")
.D BMES^XPDUTL(" **************************************************************************")
.S @XPDGREF@("PSSMLMSG",PSSMXUA2)="*** Due to error(s), UPDATE_STATUS web service definition is not complete." S PSSMXUA2=PSSMXUA2+1
I '$G(PSSWSERR) D BMES^XPDUTL("Web Service definition process is complete for PPSN web server.") D
.S @XPDGREF@("PSSMLMSG",PSSMXUA2)="Web Service definition process is complete." S PSSMXUA2=PSSMXUA2+1
D LINE
Q
;
LINE ;
S @XPDGREF@("PSSMLMSG",PSSMXUA2)=" " S PSSMXUA2=PSSMXUA2+1
Q
;
PSSENABL ;
S DIC="^XOB(18.12,"_PPSWPPSN_",100,",DLAYGO=18.121,DIC(0)="L",DA(1)=PPSWPPSN,X="UPDATE_STATUS" D ^DIC S PSSWSER2=+Y
PSSENAB2 ;
S DIE="^XOB(18.12,"_PPSWPPSN_",100,",DR=".06///ENABLE",DA(1)=PPSWPPSN,DA=PSSWSER2 D ^DIE
S PSSWSSTA=$$GET1^DIQ(18.121,PSSWSER2_",1",".06","I")
I PSSWSSTA D
.D BMES^XPDUTL(" UPDATE_STATUS web service has been enabled.")
.S @XPDGREF@("PSSMLMSG",PSSMXUA2)=" UPDATE_STATUS web service has been enabled." S PSSMXUA2=PSSMXUA2+1
Q
;
FILESRVR(PSNSRVR,PSNADRS,PSNPORT) ; File a new record in file #18.12 or edit existing
; Input: PSNSRVR - web server name
; PSNADRS - web server address
; PSNPORT - port number
; Output:
; Function Value - Returns IEN of record on success, 0 on failure
;
N FDA,FDAI,PSNERR,PSNIENS,PSNIEN,DIERR
S PSNIEN=+$$FIND1^DIC(18.12,"","BX",PSNSRVR,"","","")
;
; If record doesn't already exist, create new
I PSNIEN S PSNIENS=PSNIEN_","
E S PSNIENS="+1,"
D BMES^XPDUTL($S(PSNIEN:"Updating",1:"Creating")_" PPSN Web Server...")
S @XPDGREF@("PSSMLMSG",PSSMXUA2)=$S(PSNIEN:"Updating",1:"Creating")_" PPSN Web Server..."
S PSSMXUA2=PSSMXUA2+1
;
; Set up FDA with field values
S FDA(18.12,PSNIENS,.01)=$G(PSNSRVR) ;server name
S FDA(18.12,PSNIENS,.03)=$G(PSNPORT) ;ws port nbr
I 'PSNIEN S FDA(18.12,PSNIENS,.04)=$G(PSNADRS) ;server address
S FDA(18.12,PSNIENS,.06)=1 ;status
S FDA(18.12,PSNIENS,.07)=30 ;timeout
S FDA(18.12,PSNIENS,3.01)=1 ;ssl enabled
S FDA(18.12,PSNIENS,3.02)="encrypt_only" ;SSL configuration
S FDA(18.12,PSNIENS,3.03)=443 ;SSL port number
;
I PSNIEN D ;update current record
. D FILE^DIE("K","FDA","PSNERR")
. I $D(PSNERR) D
. . D DISPERR($NA(PSNERR),PSSMXUA2)
. . S PSNIEN=0
E D ;create new record
. D UPDATE^DIE("","FDA","FDAI","PSNERR")
. I $D(PSNERR) D
. . D DISPERR($NA(PSNERR),PSSMXUA2)
. . S PSNIEN=0
. E D
. . S PSNIEN=$G(FDAI(1))
;
Q $S($G(PSNIEN)>0:PSNIEN,1:0)
;
SERVICE(SVCS,SRVR,SVRIEN) ; add web service to web server
; Input: SVCS - web service name
; SRVR - web server name
; SVRIEN - web server ien
;
N SVCIEN,PSNIENS,PSNFDA,PSNFDAI,PSNERR,DIERR
;
S SVCIEN=+$$FIND1^DIC(18.02,"","BX",SVCS,"","","")
I '$D(^XOB(18.12,"AB",SVCIEN,SVRIEN)) D
. ;add sub rec
. S PSNIENS="+1,"_SVRIEN_","
. S PSNFDA(18.121,PSNIENS,.01)=SVCIEN ;service ien
. S PSNFDA(18.121,PSNIENS,.06)=1 ;status
. D UPDATE^DIE("","PSNFDA","PSNFDAI","PSNERR")
. I $D(DIERR) D
. . D DISPERR($NA(PSNERR))
. . D MES^XPDUTL(" o ERROR occurred registering WEB SERVICE '"_SVCS_"' to WEB SERVER '"_SRVR_"'")
. . D MES^XPDUTL(" ")
. E D
. . D MES^XPDUTL(" o WEB SERVICE '"_SVCS_"' was registered to WEB SERVER '"_SRVR_"'")
. . D MES^XPDUTL(" ")
. D CLEAN^DILF
E D
. D MES^XPDUTL(" o WEB SERVICE '"_SVCS_"' already registered to WEB SERVER '"_SRVR_"'")
. D MES^XPDUTL(" ")
Q
;
DISPERR(PSNARR,PSSMXUA2) ; display error message
N PSNOUT,PSNI
W !,"Database Server Error Information:" S PSSMXUA2=PSSMXUA2+1
D MSG^DIALOG("AE",.PSNOUT,70,"",PSNARR)
F PSNI=1:1 Q:$D(PSNOUT(PSNI))=0 W !,$G(PSNOUT(PSNI)) S PSSMXUA2=PSSMXUA2+1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSN513PO 9229 printed Sep 23, 2025@19:58:44 Page 2
PSN513PO ;BIR/SJA-Post install routine for patch PSN*4*513 ; 19 Jan 2017 1:20 PM
+1 ;;4.0;NATIONAL DRUG FILE;**513**; 30 Oct 98;Build 53
+2 ;
+3 QUIT
POST ; -- post-install entry
+1 NEW II,PSNA,ITEM,PSNSVR1
SET PSSMXUA2=1
+2 ; delete invalid hazard waste entries
+3 SET II=0
FOR
SET II=$ORDER(^PSNDF(50.68,II))
if 'II
QUIT
Begin DoDot:1
+4 IF $GET(^PSNDF(50.68,II,"HAZTODIS2",0))=0
KILL ^PSNDF(50.68,II,"HAZTODIS2",0)
End DoDot:1
+5 ;
+6 DO BMES^XPDUTL("Rebuilding National Drug File Menu....")
+7 DO ADD
+8 DO BMES^XPDUTL("Rebuilding menus complete.")
+9 DO PPSN
+10 DO SETWS
+11 SET PSNSVR1=$$FILESRVR("PPSN","vaausppsapp21.aac.domain.ext",443)
+12 ; add web service to web server
DO SERVICE("UPDATE_STATUS","PPSN",PSNSVR1)
+13 QUIT
+14 ;
ADD ; -- add new menu option and update order for PSNMGR & PSN PPS MENU
+1 SET PSNA=$$ADD^XPDMENU("PSNMGR","PSNPMIS PRINT","PMIS",9)
+2 SET PSNA=$$ADD^XPDMENU("PSNMGR","PSN MED GUIDE","FDA",10)
+3 SET PSNA=$$ADD^XPDMENU("PSNMGR","PSN PPS MENU","PPS",20)
+4 DO BMES^XPDUTL(" PSN PPS MENU option "_$SELECT('+$GET(PSNA):"NOT ",1:"")_"added to menu PSNMGR")
+5 DO BMES^XPDUTL("Updating PSN PPS MENU menu display order...")
+6 SET ITEM="PSN PPS SCHEDULE DOWNLOAD"
SET PSNA=$$ADD^XPDMENU("PSN PPS MENU",ITEM,"SD",1)
DO MSG(ITEM,PSNA)
+7 SET ITEM="PSN PPS SCHEDULE INSTALL"
SET PSNA=$$ADD^XPDMENU("PSN PPS MENU",ITEM,"SI",2)
+8 SET ITEM="PSN PPS MANUAL DOWNLOAD"
SET PSNA=$$ADD^XPDMENU("PSN PPS MENU",ITEM,"MD",3)
+9 SET ITEM="PSN PPS MANUAL INSTALL"
SET PSNA=$$ADD^XPDMENU("PSN PPS MENU",ITEM,"MI",4)
+10 SET ITEM="PSN PPS REJECT FILE"
SET PSNA=$$ADD^XPDMENU("PSN PPS MENU",ITEM,"RJ",5)
+11 SET ITEM="PSN PPS PARAM"
SET PSNA=$$ADD^XPDMENU("PSN PPS MENU",ITEM,"SP",6)
+12 DO MES^XPDUTL("Display order updated")
+13 QUIT
MSG(ITEM,PSNA) ; -- write message
+1 DO BMES^XPDUTL(" "_ITEM_" option "_$SELECT('+$GET(PSNA):"NOT ",1:"")_"added to menu PSN PPS MENU")
+2 QUIT
PPSN ; -- add new entry in ^PS(57.23 if it doesn't exist
+1 if $ORDER(^PS(57.23,0))
QUIT
+2 NEW PSNTN,RADD,RUSR
+3 KILL DA,DIC
SET X="PPSN"
SET DIC="^PS(57.23,"
SET DIC(0)="L"
DO FILE^DICN
KILL DIC
+4 SET PSNTN=+Y
+5 SET RADD="vaausmocftpprd01.aac.domain.ext"
SET RUSR="presftp"
+6 SET DA=PSNTN
SET DIE=57.23
SET DR="2///0;8///0;9///N;10///N;20///"_RADD_";22///"_RUSR_";45///Y"
DO ^DIE
KILL DR
+7 SET $PIECE(^PS(59.7,1,10),"^",12)="P"
+8 QUIT
+9 ;
SETWS ;define UPDATE_STATUS web service
+1 NEW PSSWSERV,PSSWSER2,PPSWPPSN,PSSWSCNT,PSSWSMSG,PSSWSSTA,PSSWSERR,DA,DIE,DIC,DR,X,Y,DLAYGO,WSARR
+2 SET (PSSWSERR,PSSWSCNT)=0
SET PSSMXUA2=1
+3 SET DIC="^XOB(18.12,"
SET X="PPSN"
SET DIC(0)="X"
DO ^DIC
+4 IF Y<1
Begin DoDot:1
+5 DO BMES^XPDUTL(" Creating PPSN web server.")
SET PSSMXUA2=PSSMXUA2+1
+6 SET WSARR("WSDL FILE")=""
+7 SET WSARR("CACHE PACKAGE NAME")=""
+8 SET WSARR("WEB SERVICE NAME")="PPSN"
+9 SET WSARR("AVAILABILITY RESOURCE")="?wsdl"
+10 SET XOBSTAT=$$GENPORT^XOBWLIB(.WSARR)
+11 SET DIC="^XOB(18.12,"
SET X="PPSN"
SET DIC(0)=X
End DoDot:1
+12 ;find the PPSN web server IEN
SET PPSWPPSN=+Y
KILL DIC
+13 DO BMES^XPDUTL("Beginning UPDATE_STATUS Web Service definition for PPSN web server: ")
+14 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)="Beginning UPDATE_STATUS Web Service definition: "
SET PSSMXUA2=PSSMXUA2+1
+15 IF PPSWPPSN=-1
Begin DoDot:1
+16 DO BMES^XPDUTL(" PPSN Web Server is not defined. Please contact product support.")
SET PSSWSERR=1
+17 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)=" PPSN Web Server isn't defined and UPDATE_STATUS Web Service couldn't be"
SET PSSMXUA2=PSSMXUA2+1
+18 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)=" created. Please log a National Help Desk Ticket and refer to this message."
SET PSSMXUA2=PSSMXUA2+1
End DoDot:1
GOTO SETWSQT
SETWS2 ;
+1 ;get the IEN for the UPDATE_STATUS web service
SET DIC="^XOB(18.02,"
SET X="UPDATE_STATUS"
SET DIC(0)="X"
DO ^DIC
SET PSSWSERV=+Y
+2 ;if not there register the web service
IF +Y<1
IF PSSWSCNT=0
DO REGREST^XOBWLIB("UPDATE_STATUS","/PRE/ndf/update/","status")
HANG 3
SET PSSWSCNT=1
GOTO SETWS2
+3 IF +Y<1
Begin DoDot:1
+4 DO BMES^XPDUTL(" UPDATE_STATUS web service has NOT been created. Please contact product support.")
+5 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)=" UPDATE_STATUS web service has NOT been defined. Please log a"
SET PSSMXUA2=PSSMXUA2+1
SET PSSWSERR=1
+6 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)=" National Help Desk ticket and refer to this message."
SET PSSMXUA2=PSSMXUA2+1
+7 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)=" "
SET PSSMXUA2=PSSMXUA2+1
End DoDot:1
HANG 3
GOTO SETWSQT
+8 SET PSSWSMSG=$SELECT(PSSWSCNT=0:"UPDATE_STATUS web service was previously defined. No action taken.",1:"UPDATE_STATUS web service has been defined.")
+9 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)=" "_PSSWSMSG
SET PSSMXUA2=PSSMXUA2+1
+10 DO BMES^XPDUTL(" "_PSSWSMSG)
+11 ;
+12 KILL DIC,DIE,DA,DR,X,Y
+13 SET DIC="^XOB(18.12,"_PPSWPPSN_",100,"
SET X="UPDATE_STATUS"
SET DIC(0)="X"
DO ^DIC
SET PSSWSER2=+Y
+14 LOCK +^XOB(18.12,PPSWPPSN):20
IF '$TEST
Begin DoDot:1
+15 DO BMES^XPDUTL(" Unable to lock file 18.12 to enable UPDATE_STATUS web service. Please ")
+16 DO BMES^XPDUTL(" contact product support.")
+17 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)=" Unable to lock file 18.12 to enable UPDATE_STATUS web service."
SET PSSMXUA2=PSSMXUA2+1
+18 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)=" Please contact the National Help Desk and refer to this message."
SET PSSMXUA2=PSSMXUA2+1
SET PSSWSERR=1
End DoDot:1
HANG 3
GOTO SETWSQT
+19 IF PSSWSER2=-1
DO PSSENABL
GOTO SETWSQT
+20 SET PSSWSSTA=$$GET1^DIQ(18.121,PSSWSER2_",1",".06","I")
+21 IF PSSWSSTA=-1
DO PSSENABL
GOTO SETWSQT
+22 IF PSSWSSTA=""!(PSSWSSTA=0)
DO PSSENAB2
GOTO SETWSQT
+23 IF PSSWSSTA
Begin DoDot:1
+24 DO BMES^XPDUTL(" UPDATE_STATUS web service was previously enabled. No action taken.")
+25 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)=" UPDATE_STATUS web service was previously enabled. No action taken."
SET PSSMXUA2=PSSMXUA2+1
End DoDot:1
SETWSQT ;
+1 LOCK -^XOB(18.12,PPSWPPSN)
+2 IF $GET(PSSWSERR)
Begin DoDot:1
+3 DO BMES^XPDUTL(" **************************************************************************")
+4 DO BMES^XPDUTL(" ** Due to error(s), UPDATE_STATUS web service definition is not complete. **")
+5 DO BMES^XPDUTL(" **************************************************************************")
+6 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)="*** Due to error(s), UPDATE_STATUS web service definition is not complete."
SET PSSMXUA2=PSSMXUA2+1
End DoDot:1
+7 IF '$GET(PSSWSERR)
DO BMES^XPDUTL("Web Service definition process is complete for PPSN web server.")
Begin DoDot:1
+8 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)="Web Service definition process is complete."
SET PSSMXUA2=PSSMXUA2+1
End DoDot:1
+9 DO LINE
+10 QUIT
+11 ;
LINE ;
+1 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)=" "
SET PSSMXUA2=PSSMXUA2+1
+2 QUIT
+3 ;
PSSENABL ;
+1 SET DIC="^XOB(18.12,"_PPSWPPSN_",100,"
SET DLAYGO=18.121
SET DIC(0)="L"
SET DA(1)=PPSWPPSN
SET X="UPDATE_STATUS"
DO ^DIC
SET PSSWSER2=+Y
PSSENAB2 ;
+1 SET DIE="^XOB(18.12,"_PPSWPPSN_",100,"
SET DR=".06///ENABLE"
SET DA(1)=PPSWPPSN
SET DA=PSSWSER2
DO ^DIE
+2 SET PSSWSSTA=$$GET1^DIQ(18.121,PSSWSER2_",1",".06","I")
+3 IF PSSWSSTA
Begin DoDot:1
+4 DO BMES^XPDUTL(" UPDATE_STATUS web service has been enabled.")
+5 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)=" UPDATE_STATUS web service has been enabled."
SET PSSMXUA2=PSSMXUA2+1
End DoDot:1
+6 QUIT
+7 ;
FILESRVR(PSNSRVR,PSNADRS,PSNPORT) ; File a new record in file #18.12 or edit existing
+1 ; Input: PSNSRVR - web server name
+2 ; PSNADRS - web server address
+3 ; PSNPORT - port number
+4 ; Output:
+5 ; Function Value - Returns IEN of record on success, 0 on failure
+6 ;
+7 NEW FDA,FDAI,PSNERR,PSNIENS,PSNIEN,DIERR
+8 SET PSNIEN=+$$FIND1^DIC(18.12,"","BX",PSNSRVR,"","","")
+9 ;
+10 ; If record doesn't already exist, create new
+11 IF PSNIEN
SET PSNIENS=PSNIEN_","
+12 IF '$TEST
SET PSNIENS="+1,"
+13 DO BMES^XPDUTL($SELECT(PSNIEN:"Updating",1:"Creating")_" PPSN Web Server...")
+14 SET @XPDGREF@("PSSMLMSG",PSSMXUA2)=$SELECT(PSNIEN:"Updating",1:"Creating")_" PPSN Web Server..."
+15 SET PSSMXUA2=PSSMXUA2+1
+16 ;
+17 ; Set up FDA with field values
+18 ;server name
SET FDA(18.12,PSNIENS,.01)=$GET(PSNSRVR)
+19 ;ws port nbr
SET FDA(18.12,PSNIENS,.03)=$GET(PSNPORT)
+20 ;server address
IF 'PSNIEN
SET FDA(18.12,PSNIENS,.04)=$GET(PSNADRS)
+21 ;status
SET FDA(18.12,PSNIENS,.06)=1
+22 ;timeout
SET FDA(18.12,PSNIENS,.07)=30
+23 ;ssl enabled
SET FDA(18.12,PSNIENS,3.01)=1
+24 ;SSL configuration
SET FDA(18.12,PSNIENS,3.02)="encrypt_only"
+25 ;SSL port number
SET FDA(18.12,PSNIENS,3.03)=443
+26 ;
+27 ;update current record
IF PSNIEN
Begin DoDot:1
+28 DO FILE^DIE("K","FDA","PSNERR")
+29 IF $DATA(PSNERR)
Begin DoDot:2
+30 DO DISPERR($NAME(PSNERR),PSSMXUA2)
+31 SET PSNIEN=0
End DoDot:2
End DoDot:1
+32 ;create new record
IF '$TEST
Begin DoDot:1
+33 DO UPDATE^DIE("","FDA","FDAI","PSNERR")
+34 IF $DATA(PSNERR)
Begin DoDot:2
+35 DO DISPERR($NAME(PSNERR),PSSMXUA2)
+36 SET PSNIEN=0
End DoDot:2
+37 IF '$TEST
Begin DoDot:2
+38 SET PSNIEN=$GET(FDAI(1))
End DoDot:2
End DoDot:1
+39 ;
+40 QUIT $SELECT($GET(PSNIEN)>0:PSNIEN,1:0)
+41 ;
SERVICE(SVCS,SRVR,SVRIEN) ; add web service to web server
+1 ; Input: SVCS - web service name
+2 ; SRVR - web server name
+3 ; SVRIEN - web server ien
+4 ;
+5 NEW SVCIEN,PSNIENS,PSNFDA,PSNFDAI,PSNERR,DIERR
+6 ;
+7 SET SVCIEN=+$$FIND1^DIC(18.02,"","BX",SVCS,"","","")
+8 IF '$DATA(^XOB(18.12,"AB",SVCIEN,SVRIEN))
Begin DoDot:1
+9 ;add sub rec
+10 SET PSNIENS="+1,"_SVRIEN_","
+11 ;service ien
SET PSNFDA(18.121,PSNIENS,.01)=SVCIEN
+12 ;status
SET PSNFDA(18.121,PSNIENS,.06)=1
+13 DO UPDATE^DIE("","PSNFDA","PSNFDAI","PSNERR")
+14 IF $DATA(DIERR)
Begin DoDot:2
+15 DO DISPERR($NAME(PSNERR))
+16 DO MES^XPDUTL(" o ERROR occurred registering WEB SERVICE '"_SVCS_"' to WEB SERVER '"_SRVR_"'")
+17 DO MES^XPDUTL(" ")
End DoDot:2
+18 IF '$TEST
Begin DoDot:2
+19 DO MES^XPDUTL(" o WEB SERVICE '"_SVCS_"' was registered to WEB SERVER '"_SRVR_"'")
+20 DO MES^XPDUTL(" ")
End DoDot:2
+21 DO CLEAN^DILF
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 DO MES^XPDUTL(" o WEB SERVICE '"_SVCS_"' already registered to WEB SERVER '"_SRVR_"'")
+24 DO MES^XPDUTL(" ")
End DoDot:1
+25 QUIT
+26 ;
DISPERR(PSNARR,PSSMXUA2) ; display error message
+1 NEW PSNOUT,PSNI
+2 WRITE !,"Database Server Error Information:"
SET PSSMXUA2=PSSMXUA2+1
+3 DO MSG^DIALOG("AE",.PSNOUT,70,"",PSNARR)
+4 FOR PSNI=1:1
if $DATA(PSNOUT(PSNI))=0
QUIT
WRITE !,$GET(PSNOUT(PSNI))
SET PSSMXUA2=PSSMXUA2+1
+5 QUIT
+6 ;
