DVBHQDL ;ISC-ALBANY/PKE-HINQ IDCU,RDPC LOGON ; Sep 30, 2021@09:08
;;4.0;HINQ;**9,12,32,33,34,38,49,71**;03/25/92;Build 13
Q ;Patch DVB*4.0*71 prevents VistA HINQ requests due to WEBHINQ transition
S X="A" X ^%ZOSF("LPC") K X S U="^" I $D(IO)<11 S IOP="HOME" D ^%ZIS K IOP S:'$D(DTIME) DTIME=300
I $D(DUZ)#2'=1 W !,"DUZ not defined",! Q
I $D(^VA(200,DUZ,.1)) S DVBNUM=$P(^(.1),U,9) I DVBNUM
E W !," HINQ Employee Number not in New Person file",!," Notify System manager",! Q
;
EN Q ;Patch DVB*4.0*71 prevents VistA HINQ requests due to WEBHINQ transition
W !,"This option will take 30 seconds to activate - using IP Addressing"
U IO(0) W !!,"Do you wish to continue" S %=1 D YN^DICN
I %'>0 G:%<0 EX1 W !," Enter YES to select option" G EN
I %>1 G EX1
S DVBTSK=0
S DVBIOSL=IOSL,DVBIOST=IOST,DVBIOF=IOF
ENTSK Q ;Patch DVB*4.0*71 prevents VistA HINQ requests due to WEBHINQ transition ;entry from taskman
D SILENT^DVBHQTM I $D(DVBSTOP) S DVBABORT=1 K DVBSTOP D:'DVBTSK MESS G EX
S DVBIDCU=^DVB(395,1,"HQVD")_"^"_$P(^("HQ"),"^",11)
S DVBLOG=$P(DVBIDCU,U),DVBPU=$P(DVBIDCU,U,2),DVBID=$P(DVBPU,"-"),DVBPW=$P(DVBPU,"-",2)
I DVBLOG'?3U1"."4U W:'DVBTSK !,"IDCU ADDRESS not correct in HINQ Parameter file #395" H 3 S DVBABORT=1 G END
I $P(DVBIDCU,"^",6) S DVBLOG="VHA"_$P(DVBLOG,"DMS",2)
I 'DVBTSK U IO(0) W !!,"Connecting to VBA database"
;
;Set up the error trap for cache
I 'DVBTSK,$$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^DVBHQDL"
I 'DVBTSK,'$$NEWERR^%ZTER S X="ERR^DVBHQDL",@^%ZOSF("TRAP")
;
S DVBIP=$P($G(^DVB(395,1,"HQIP")),"^",1)
I DVBIP,DVBIP?1.3N1P1.3N1P1.3N1P1.3N
E W:'DVBTSK !?3,"RDPC IP Address not defined or invalid in DVB parameter file #395" H 3 G EX1
;
S DVBSTN=$P(^DVB(395,1,0),U,2)
;
;with patch DVB*4*49 new routing and interface engines have been
;established for the HINQ process. It was decided that multiple
;ports would be added to handle the volume of HINQs. Three ports
;be used exclusively for the HEC, six for the VAMCs. A new field
;(#23 - AAC PORT DESIGNATOR) has been added to act as a counter for
;the HINQ connections that have been requested. #3 or #6 + this field
;yeilds a code that is then interpreted into a port number depending
;on the station number.
S DVBPORT=$$PORT(DVBSTN)
;
D CALL^%ZISTCP(DVBIP,DVBPORT,"33")
I POP G BUSY
S X=0
U IO X ^%ZOSF("EOFF"),^%ZOSF("TYPE-AHEAD"),^%ZOSF("RM") H 3
S C=0 ;leave this off of next line
NAM ;
HEL ;
N DVBFLG,DVBHEL,DVBQUIT
I DVBTSK D
. K X U IO F Z=1:1:50 R X(Z):3 D Q:$G(DVBQUIT)=1
. . I X(Z)["**HELLO**" K X S DVBABORT=0,DVBQUIT=1 Q
. . I '$L(X(Z)) Q
. . I $G(DVBFLG)>0 D HELLO2(Z)
. . I $G(DVBHEL)["**HELLO**" K X S DVBABORT=0,DVBQUIT=1 Q
. . S DVBFLG=0
. . I X(Z)["**H" D HELLO(Z)
. . I $E(X(Z),$L(X(Z)))="*" D HELLO(Z)
. I Z'<50 S DVBVBA="NO"
I 'DVBTSK D
. U IO(0) W !!,"One moment, please...",!! U IO
. K X F Z2=1:1:50 U IO R X(Z2):3 U IO(0) W "." D Q:$G(DVBQUIT)=1
. . I X(Z2)["**HELLO**" D CONT S DVBQUIT=1 Q
. . I '$L(X(Z2)) Q
. . I $G(DVBFLG)>0 D HELLO2(Z2)
. . I $G(DVBHEL)["**HELLO**" D CONT S DVBQUIT=1 Q
. . S DVBFLG=0
. . I X(Z2)["**H" D HELLO(Z2)
. . I $E(X(Z2),$L(X(Z2)))="*" D HELLO(Z2)
. I Z2'<50 U IO(0) W !,"HINQ not allowed at this time" D MESS U IO
END ;
I DVBTSK Q
I DVBLOG["VHA" U IO W "$%$DIS",$C(13),!
I DVBLOG'["VHA" U IO W "$$$BYEF",$C(13)
U IO(0) W !!,"Terminating VBA session...",! U IO
U IO F Z=1:1:6 R X(Z):1 Q:'$T I X(Z)["0900 BYE" U IO(0) W !,"VBA DISCONNECTED",! Q ;U IO Q
;I '$D(DVBIO) Q
;
EX I DVBTSK S DVBABORT=1 Q
EX1 K %,DVBNUM,DVBTSK,DVBLOG,DVBDEV,DVBVDI,DVBABORT,X,Y,Z,C,G,DVBIP,DVBIOSL,DVBIOST,DVBIOF
D CLOSE^%ZISTCP Q
Q
XXX I 'DVBTSK U IO(0) W !,X U IO
RESET S C=C+1 I C>2 G END
H 5 G NAM
;
BUSY I 'DVBTSK W !," ",IO," Device is busy" D SUS H 1 G EX
YYY I 'DVBTSK U IO(0) W !,"Bad Network User ID/Password notify Site Manager " H 1 G EX
Q
SUS I 'DVBTSK U IO(0) W !,"Enter requests in the Suspense file" Q
Q
ERR ;Come here on error, screen with error screens
S DVBHERR=$$EC^%ZOSV
I DVBHERR["READ"!(DVBHERR["ENDOFFIL") DO
. U IO(0) W !,"Disconnect trapped..."
D ^%ZTER
D CLOSE^%ZISTCP
G UNWIND^%ZTER
Q
MESS ;DVB*38 HINQ UNAVAILABLE MESSAGE MLR 5.10.01
I $G(DVBTSK)>0 Q
U IO(0)
W !!
W $$CJ^XLFSTR("ATTENTION: HINQ IS CURRENTLY UNAVAILABLE!",80,".")
W !!,$$CJ^XLFSTR("Please enter HINQ request in Suspense File",80)
W !,$$CJ^XLFSTR("or try again later.",80)
W !!
Q ;MESS
;
CONT ;display messages and continue with HINQ
U IO(0) W !!,"You may continue with your HINQ request...",!!
U IO S DVBIO=IO D ^DVBHQD1 U IO(0) W ! S IO=DVBIO
Q
;
HELLO(IND) ;if **HELLO** string was broken up, save it to a var to combine
;with next read
;input parameter indicates whether called from task or direct
S DVBFLG=1
I X(IND)["**H" S DVBHEL="**H"_$P(X(IND),"**H",2) Q
I $E(X(IND),$L(X(IND))-1)="*" S DVBHEL="**" Q
S DVBHEL="*"
Q
HELLO2(IND) ;add string from next read to string in HELLO
I $G(DVBHEL)["" S DVBHEL=DVBHEL_$E(X(IND),1,9-$L(DVBHEL))
Q
;
PORT(DVBSTN) ;
K DVBERR
S DVBPORT=50010
S DVBPT=$$GET1^DIQ(395,"1,",23,,,"DVBERR")
I $D(DVBERR) D Q DVBPORT
. S DVBFDA(395,"1,",23)=0
. D FILE^DIE(,"DVBFDA","DVBERR")
S DVBFDA(395,"1,",23)=DVBPT+1
D FILE^DIE("E","DVBFDA","DVBERR")
I $G(DVBSTN)=742 D
. ;station 742 is the HEC - these 3 ports are reserved for the HEC
. S DVBPORT=$G(DVBPT)#3 ;50000 - 50002
. S DVBPORT=50000+DVBPORT
I $G(DVBSTN)'=742 D
. ;these 6 ports are for the use of VAMCs
. S DVBPORT=$G(DVBPT)#6
. S DVBPORT=50010+DVBPORT ;50010 - 50015
Q DVBPORT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHQDL 5666 printed Oct 16, 2024@17:59:27 Page 2
DVBHQDL ;ISC-ALBANY/PKE-HINQ IDCU,RDPC LOGON ; Sep 30, 2021@09:08
+1 ;;4.0;HINQ;**9,12,32,33,34,38,49,71**;03/25/92;Build 13
+2 ;Patch DVB*4.0*71 prevents VistA HINQ requests due to WEBHINQ transition
QUIT
+3 SET X="A"
XECUTE ^%ZOSF("LPC")
KILL X
SET U="^"
IF $DATA(IO)<11
SET IOP="HOME"
DO ^%ZIS
KILL IOP
if '$DATA(DTIME)
SET DTIME=300
+4 IF $DATA(DUZ)#2'=1
WRITE !,"DUZ not defined",!
QUIT
+5 IF $DATA(^VA(200,DUZ,.1))
SET DVBNUM=$PIECE(^(.1),U,9)
IF DVBNUM
+6 IF '$TEST
WRITE !," HINQ Employee Number not in New Person file",!," Notify System manager",!
QUIT
+7 ;
EN ;Patch DVB*4.0*71 prevents VistA HINQ requests due to WEBHINQ transition
QUIT
+1 WRITE !,"This option will take 30 seconds to activate - using IP Addressing"
+2 USE IO(0)
WRITE !!,"Do you wish to continue"
SET %=1
DO YN^DICN
+3 IF %'>0
if %<0
GOTO EX1
WRITE !," Enter YES to select option"
GOTO EN
+4 IF %>1
GOTO EX1
+5 SET DVBTSK=0
+6 SET DVBIOSL=IOSL
SET DVBIOST=IOST
SET DVBIOF=IOF
ENTSK ;Patch DVB*4.0*71 prevents VistA HINQ requests due to WEBHINQ transition ;entry from taskman
QUIT
+1 DO SILENT^DVBHQTM
IF $DATA(DVBSTOP)
SET DVBABORT=1
KILL DVBSTOP
if 'DVBTSK
DO MESS
GOTO EX
+2 SET DVBIDCU=^DVB(395,1,"HQVD")_"^"_$PIECE(^("HQ"),"^",11)
+3 SET DVBLOG=$PIECE(DVBIDCU,U)
SET DVBPU=$PIECE(DVBIDCU,U,2)
SET DVBID=$PIECE(DVBPU,"-")
SET DVBPW=$PIECE(DVBPU,"-",2)
+4 IF DVBLOG'?3U1"."4U
if 'DVBTSK
WRITE !,"IDCU ADDRESS not correct in HINQ Parameter file #395"
HANG 3
SET DVBABORT=1
GOTO END
+5 IF $PIECE(DVBIDCU,"^",6)
SET DVBLOG="VHA"_$PIECE(DVBLOG,"DMS",2)
+6 IF 'DVBTSK
USE IO(0)
WRITE !!,"Connecting to VBA database"
+7 ;
+8 ;Set up the error trap for cache
+9 IF 'DVBTSK
IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^DVBHQDL"
+10 IF 'DVBTSK
IF '$$NEWERR^%ZTER
SET X="ERR^DVBHQDL"
SET @^%ZOSF("TRAP")
+11 ;
+12 SET DVBIP=$PIECE($GET(^DVB(395,1,"HQIP")),"^",1)
+13 IF DVBIP
IF DVBIP?1.3N1P1.3N1P1.3N1P1.3N
+14 IF '$TEST
if 'DVBTSK
WRITE !?3,"RDPC IP Address not defined or invalid in DVB parameter file #395"
HANG 3
GOTO EX1
+15 ;
+16 SET DVBSTN=$PIECE(^DVB(395,1,0),U,2)
+17 ;
+18 ;with patch DVB*4*49 new routing and interface engines have been
+19 ;established for the HINQ process. It was decided that multiple
+20 ;ports would be added to handle the volume of HINQs. Three ports
+21 ;be used exclusively for the HEC, six for the VAMCs. A new field
+22 ;(#23 - AAC PORT DESIGNATOR) has been added to act as a counter for
+23 ;the HINQ connections that have been requested. #3 or #6 + this field
+24 ;yeilds a code that is then interpreted into a port number depending
+25 ;on the station number.
+26 SET DVBPORT=$$PORT(DVBSTN)
+27 ;
+28 DO CALL^%ZISTCP(DVBIP,DVBPORT,"33")
+29 IF POP
GOTO BUSY
+30 SET X=0
+31 USE IO
XECUTE ^%ZOSF("EOFF")
XECUTE ^%ZOSF("TYPE-AHEAD")
XECUTE ^%ZOSF("RM")
HANG 3
+32 ;leave this off of next line
SET C=0
NAM ;
HEL ;
+1 NEW DVBFLG,DVBHEL,DVBQUIT
+2 IF DVBTSK
Begin DoDot:1
+3 KILL X
USE IO
FOR Z=1:1:50
READ X(Z):3
Begin DoDot:2
+4 IF X(Z)["**HELLO**"
KILL X
SET DVBABORT=0
SET DVBQUIT=1
QUIT
+5 IF '$LENGTH(X(Z))
QUIT
+6 IF $GET(DVBFLG)>0
DO HELLO2(Z)
+7 IF $GET(DVBHEL)["**HELLO**"
KILL X
SET DVBABORT=0
SET DVBQUIT=1
QUIT
+8 SET DVBFLG=0
+9 IF X(Z)["**H"
DO HELLO(Z)
+10 IF $EXTRACT(X(Z),$LENGTH(X(Z)))="*"
DO HELLO(Z)
End DoDot:2
if $GET(DVBQUIT)=1
QUIT
+11 IF Z'<50
SET DVBVBA="NO"
End DoDot:1
+12 IF 'DVBTSK
Begin DoDot:1
+13 USE IO(0)
WRITE !!,"One moment, please...",!!
USE IO
+14 KILL X
FOR Z2=1:1:50
USE IO
READ X(Z2):3
USE IO(0)
WRITE "."
Begin DoDot:2
+15 IF X(Z2)["**HELLO**"
DO CONT
SET DVBQUIT=1
QUIT
+16 IF '$LENGTH(X(Z2))
QUIT
+17 IF $GET(DVBFLG)>0
DO HELLO2(Z2)
+18 IF $GET(DVBHEL)["**HELLO**"
DO CONT
SET DVBQUIT=1
QUIT
+19 SET DVBFLG=0
+20 IF X(Z2)["**H"
DO HELLO(Z2)
+21 IF $EXTRACT(X(Z2),$LENGTH(X(Z2)))="*"
DO HELLO(Z2)
End DoDot:2
if $GET(DVBQUIT)=1
QUIT
+22 IF Z2'<50
USE IO(0)
WRITE !,"HINQ not allowed at this time"
DO MESS
USE IO
End DoDot:1
END ;
+1 IF DVBTSK
QUIT
+2 IF DVBLOG["VHA"
USE IO
WRITE "$%$DIS",$CHAR(13),!
+3 IF DVBLOG'["VHA"
USE IO
WRITE "$$$BYEF",$CHAR(13)
+4 USE IO(0)
WRITE !!,"Terminating VBA session...",!
USE IO
+5 ;U IO Q
USE IO
FOR Z=1:1:6
READ X(Z):1
if '$TEST
QUIT
IF X(Z)["0900 BYE"
USE IO(0)
WRITE !,"VBA DISCONNECTED",!
QUIT
+6 ;I '$D(DVBIO) Q
+7 ;
EX IF DVBTSK
SET DVBABORT=1
QUIT
EX1 KILL %,DVBNUM,DVBTSK,DVBLOG,DVBDEV,DVBVDI,DVBABORT,X,Y,Z,C,G,DVBIP,DVBIOSL,DVBIOST,DVBIOF
+1 DO CLOSE^%ZISTCP
QUIT
+2 QUIT
XXX IF 'DVBTSK
USE IO(0)
WRITE !,X
USE IO
RESET SET C=C+1
IF C>2
GOTO END
+1 HANG 5
GOTO NAM
+2 ;
BUSY IF 'DVBTSK
WRITE !," ",IO," Device is busy"
DO SUS
HANG 1
GOTO EX
YYY IF 'DVBTSK
USE IO(0)
WRITE !,"Bad Network User ID/Password notify Site Manager "
HANG 1
GOTO EX
+1 QUIT
SUS IF 'DVBTSK
USE IO(0)
WRITE !,"Enter requests in the Suspense file"
QUIT
+1 QUIT
ERR ;Come here on error, screen with error screens
+1 SET DVBHERR=$$EC^%ZOSV
+2 IF DVBHERR["READ"!(DVBHERR["ENDOFFIL")
Begin DoDot:1
+3 USE IO(0)
WRITE !,"Disconnect trapped..."
End DoDot:1
+4 DO ^%ZTER
+5 DO CLOSE^%ZISTCP
+6 GOTO UNWIND^%ZTER
+7 QUIT
MESS ;DVB*38 HINQ UNAVAILABLE MESSAGE MLR 5.10.01
+1 IF $GET(DVBTSK)>0
QUIT
+2 USE IO(0)
+3 WRITE !!
+4 WRITE $$CJ^XLFSTR("ATTENTION: HINQ IS CURRENTLY UNAVAILABLE!",80,".")
+5 WRITE !!,$$CJ^XLFSTR("Please enter HINQ request in Suspense File",80)
+6 WRITE !,$$CJ^XLFSTR("or try again later.",80)
+7 WRITE !!
+8 ;MESS
QUIT
+9 ;
CONT ;display messages and continue with HINQ
+1 USE IO(0)
WRITE !!,"You may continue with your HINQ request...",!!
+2 USE IO
SET DVBIO=IO
DO ^DVBHQD1
USE IO(0)
WRITE !
SET IO=DVBIO
+3 QUIT
+4 ;
HELLO(IND) ;if **HELLO** string was broken up, save it to a var to combine
+1 ;with next read
+2 ;input parameter indicates whether called from task or direct
+3 SET DVBFLG=1
+4 IF X(IND)["**H"
SET DVBHEL="**H"_$PIECE(X(IND),"**H",2)
QUIT
+5 IF $EXTRACT(X(IND),$LENGTH(X(IND))-1)="*"
SET DVBHEL="**"
QUIT
+6 SET DVBHEL="*"
+7 QUIT
HELLO2(IND) ;add string from next read to string in HELLO
+1 IF $GET(DVBHEL)[""
SET DVBHEL=DVBHEL_$EXTRACT(X(IND),1,9-$LENGTH(DVBHEL))
+2 QUIT
+3 ;
PORT(DVBSTN) ;
+1 KILL DVBERR
+2 SET DVBPORT=50010
+3 SET DVBPT=$$GET1^DIQ(395,"1,",23,,,"DVBERR")
+4 IF $DATA(DVBERR)
Begin DoDot:1
+5 SET DVBFDA(395,"1,",23)=0
+6 DO FILE^DIE(,"DVBFDA","DVBERR")
End DoDot:1
QUIT DVBPORT
+7 SET DVBFDA(395,"1,",23)=DVBPT+1
+8 DO FILE^DIE("E","DVBFDA","DVBERR")
+9 IF $GET(DVBSTN)=742
Begin DoDot:1
+10 ;station 742 is the HEC - these 3 ports are reserved for the HEC
+11 ;50000 - 50002
SET DVBPORT=$GET(DVBPT)#3
+12 SET DVBPORT=50000+DVBPORT
End DoDot:1
+13 IF $GET(DVBSTN)'=742
Begin DoDot:1
+14 ;these 6 ports are for the use of VAMCs
+15 SET DVBPORT=$GET(DVBPT)#6
+16 ;50010 - 50015
SET DVBPORT=50010+DVBPORT
End DoDot:1
+17 QUIT DVBPORT
