Routine: DVBHQDL

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

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

SUS I 'DVBTSK U IO(0) W !,"Enter requests in the Suspense file" 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

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

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="*"

HELLO2(IND) ;add string from next read to string in HELLO

 I $G(DVBHEL)["" S DVBHEL=DVBHEL_$E(X(IND),1,9-$L(DVBHEL))

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  Feb 18, 2025@23:25                                                                                                                                                                                                        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

DVBHQDL.m