DVBHQUP ;ALB/JLU This routine is used for the upload option. ; 3/9/06 4:16pm
;;4.0;HINQ;**12,49,56**;03/25/92
A D A^DVBHUTIL
B W !
B1 R !,"Do you want to examine the Suspense file by 'P'atient or 'A'll P// ",K1:DTIME G:'$T KA1 D P:"Pp"[K1!(K1=""),L:"Aa"[$E(K1_1)
G:DVBOUT="^" KA1
I K1="?"!(K1'="^") W !!,*7,?15,"Answer with capital A or P <RET> also for P",!! G B1
KA1 D KA1^DVBHQEDT Q
KA D KA^DVBHQEDT
Q
P S K1="^" K DVBDIQ D P1 I Y<0 S DVBOUT="^" Q
N DVBQT,DVBTMP1,DVBTMP2
S DIE="^DPT(",(DA,DFN)=+Y,DR="[DVBHINQ UPDATE]",DVBJ2=0 D TEM^DVBHIQR
I '$D(DVBERCS) D CHKID^DVBHQD1
I $G(DVBQT) D G P
. S DVBTMP1=$G(DVBNOALR)
. S DVBTMP2=$G(DVBJ2)
. S DVBNOALR=";4///a;5////"_DUZ_";6///N",DVBJ2=1 D FILE
. S DVBNOALR=DVBTMP1
. S DVBJ2=DVBTMP2
D ^DIE:'$D(DVBERCS) K DIE,DR,DA
D C I DVBOUT'="^" G P
Q
L S ANS="",K1="^"
I '$D(^DVB(395.5,"AC","N")) W !!,"No patients to be updated." H 3 Q
F K2=0:0 S K2=$O(^DVB(395.5,"AC","N",K2)) Q:'K2!(DVBOUT="^") D
. I $D(^DVB(395.5,K2,"RS",0)),$P(^DVB(395.5,K2,0),U,5)'="Y",$P(^(0),U,5)'="I" D
. . S DIE="^DPT(",(DA,DFN)=K2,DR="[DVBHINQ UPDATE]",DVBJ2=0 D TEM^DVBHIQR
. . N DVBQT,DVBTMP1,DVBTMP2
. . S DVBQT=1
. . I '$D(DVBERCS) D CHKID^DVBHQD1 I DVBQT D Q
. . . S DVBTMP1=$G(DVBNOALR)
. . . S DVBTMP2=$G(DVBJ2)
. . . S DVBNOALR=";4///a;5////"_DUZ_";6///N",DVBJ2=1 D FILE
. . . S DVBNOALR=DVBTMP1
. . . S DVBJ2=DVBTMP2
. . D ^DIE:'$D(DVBERCS) D C,KA Q:DVBOUT="^"
Q
C ;SETS UPDATED? FIELD, RUNS INCONSIS. CHECKER.
Q:DVBOUT["^" S DVB=DFN,DVBLP=2,DVBMM=1,DVBMM2=1 D QB^DVBHQZ6
Q:'DVBJ2 I DVBJ2 S $P(^DVB(395.5,DFN,0),U,5)="Y" S DGEDCN=1 D ^DGRPC I 1
E S $P(^DVB(395.5,DFN,0),U,5)="N"
D FILE K DVBDIQ Q
;
;I '$D(^DVB(395.7,DFN,0)) K DIC,DD,DO S DIC(0)="LQ",DIC="^DVB(395.7,",DIC("DR")="1////"_DUZ_";2///"_"N",(X,DINUM)=DFN D FILE^DICN I 1
;E S DIE="^DVB(395.7,",DA=DFN,DR="1////"_DUZ_";2///"_"N" D ^DIE
;
FILE I '$D(^DVB(395.7,DFN,0)) DO
.K DIC,DD,DO S DIC(0)="LQ",DIC="^DVB(395.7,"
.S DIC("DR")="1////"_DUZ_";2///"_"N"_$S($D(DVBNOALR):DVBNOALR,1:"")
.S (X,DINUM)=DFN D FILE^DICN
E DO
.K DIC S (DIC,DIE)="^DVB(395.7,",DA=DFN
.S DR="1////"_DUZ_";2///"_"N"_$S($D(DVBNOALR):DVBNOALR,1:"")
.I 'DVBJ2,$D(DVBNOALR),DVBNOALR]"" S DR=$E(DVBNOALR,2,99)
.L +^DVB(395.7,DFN):3 I $T D ^DIE
.L -^DVB(395.7,DFN)
K DIC,DIE,DA,DR Q
;
;ENRTY PT FOR PRINT OPTION
PT W @$S('$D(IOF):"#",IOF="":"#",1:IOF),!!!!!!!!!!
PT1 R "Do you want a print out of a (S)ingle patient or (A)ll of the patients? S// ",DVBJA:DTIME G:'$T KA1 D S:DVBJA="S"!(DVBJA=""),T:DVBJA="A"
I DVBJA="?"!(DVBJA'="^") W !!,*7,?15,"Answer with a capital A or S or <RET> for S",!! G PT1
D KA1 Q
S D P1 I Y<0 S DVBJA="^" Q
S (DFN,D0,ZTSAVE("D0"),ZTSAVE("DFN"))=+Y,ZTRTN="S1^DVBHQUP" D RP I $D(IO("Q"))!POP S DVBJA="^" Q
S1 U IO D TEM^DVBHIQR,^DVBHCG:'$D(DVBERCS) I '$D(ZTSK) X ^%ZIS("C")
S DVBJA="^" Q
T S DVBJA="^",ZTRTN="RP1^DVBHQUP"
W !!,?6,"Select one of the following:",!!,?11,"1 Updated",!,?11,"2 NOT Updated",!,?11,"3 Both",!,"How would you like your print sorted? Updated//"
R Y:DTIME Q:Y="^"!('$T)
S (ZTSAVE("DVBY"),DVBY)=$S(Y=1!(Y="")!(Y["U"):1,Y=2!(Y["N"):2,Y=3!(Y["B"):3,1:"")
I DVBY="" W !!,*7,"Answer with a code from the list." G T
D CT Q
;
AU ;ENTRY POINT FOR DISPLAY OF AUDIT.
W @$S('$D(IOF):"#",IOF="":"#",1:IOF),!!!!!
AU1 W !!,?6,"Select one of the following:",!!,?11,"1 Patient",!,?11,"2 User",!,?11,"3 Date/Time",!,"By which would you like the sort to begin? : Patient//"
R Y:DTIME Q:Y="^"!('$T)
S (FLDS,BY)=$S(Y=1!(Y="")!(Y["P"):"[DVBHINQ AUDIT/PAT]",Y=2!(Y["U"):"[DVBHINQ AUDIT/USER]",Y=3!(Y["D"):"[DVBHINQ AUDIT/DT]",1:"")
I BY="" W !!,*7,"Answer with a code from the above list." G AU1
S L=0,DIC="^DVB(395.7,",(FR,TO)="" D EN1^DIP Q
;
P1 W ! D KA S DIC="^DVB(395.5,",DIC(0)="AEMZQ",DIC("S")="I ($P(^(0),U,4)=""N""),($D(^(""RS"",0)))",DIC("A")="Select Patient from ""HINQ Suspense file"":" D ^DIC K DIC Q
;
RP S %IS="MQ" D ^%ZIS Q:POP I $D(IO("Q")) S ZTDESC="This is a job for the HINQ report.",ZTIO=ION D ^%ZTLOAD X ^%ZIS("C") Q
Q:DVBJA=""!(DVBJA="S")
RP1 S DVB8="" U IO F D0=0:0 S (D0,DFN)=$O(^DVB(395.5,"AC","N",D0)) Q:'D0 S DVBJ1=$S((DVBY=1)&($P(^DVB(395.5,D0,0),U,5)="Y"):1,(DVBY=2)&($P(^(0),U,5)'="Y"):1,DVBY=3:1,1:0) D:DVBJ1 TEM^DVBHIQR,^DVBHCG:'$D(DVBERCS) Q:DVB8["^" D KA
I '$D(ZTSK) X ^%ZIS("C")
Q
;
CT S DVB1=0 F DVB=0:0 S DVB1=$O(^DVB(395.5,"AC","N",DVB1)) Q:'DVB1 S DVB=$S(DVBY=1&($P(^DVB(395.5,DVB1,0),U,5)="Y"):DVB+1,DVBY=2&($P(^(0),U,5)'="Y"):DVB+1,DVBY=3:DVB+1,1:DVB)
I 'DVB W !,"There are no patients at this time for this print." Q
CT1 W !!,"There are ",DVB," patients for this report, do you wish to continue" S %=1 D YN^DICN Q:%=2!(%<0) I '% W !,"A YES answer will continue on with the report, answer with Y or N" G CT1
D RP Q
LSTR ;lists the SC disabilities in the ReviewPatient vs. HINQ data
;option, [DVB HUPLOAD-PRINT]
;called from print template [DVBHINQ PAT-HINQ COMP]
N DVBIEN
K DVBERR
D GETS^DIQ(2,DFN_",",".302;.3014;.3721*","EI","DVBDIQ","DVBERR")
W "-Comb. SC%: "_+DVBDIQ(2,DFN_",",.302,"E")_" "
W "Eff. Date Comb. Eval.: "_DVBDIQ(2,DFN_",",.3014,"E")
I $P($G(^DPT(DFN,.372,0)),U,3)>0 D LABELS^DVBHS3
S LP=""
I $D(DVBDIQ(2.04)) F S LP=$O(DVBDIQ(2.04,LP)) Q:'LP D
. I ($Y+5)>IOSL,$E(IOST,1,2)="C-" D PAUSE^DVBHS3
. W !,$E(DVBDIQ(2.04,LP,.01,"E"),1,40),?42,DVBDIQ(2.04,LP,2,"E")
. W ?50,$G(DVBDIQ(2.04,LP,4,"I")),?55,$G(DVBDIQ(2.04,LP,5,"E"))
. W ?68,$G(DVBDIQ(2.04,LP,6,"E"))
Q
N DVBFR,DVBLAST,DVBX,QUIT
S DVBFR=""
S DVBLAST=$O(^DPT(DFN,.372,""),-1)
I $G(DVBLAST)']"" Q
F DVBX=0:0 D LOOP I $G(QUIT)=1!(DVBFR(2)>DVBLAST) K QUIT Q
Q
LOOP ;
D LIST
N DVBCT
F DVBCT=0:0 S DVBCT=$O(DVBARR("DILIST",DVBCT)) Q:'DVBCT!(DVBCT>19) D
. W !?36,$P(DVBARR("DILIST",DVBCT,0),U,2),?68,$P(DVBARR("DILIST",DVBCT,0),U,4),?74,$P(DVBARR("DILIST",DVBCT,0),U,5)
D PAUSE^DVBHS3
Q
LIST ;
D LIST^DIC(2.04,","_DFN_",",".01;2;3","P",20,.DVBFR,,,,,"DVBARR",)
I $G(DVBFR(2))'>0 S QUIT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHQUP 6049 printed Sep 23, 2025@19:35:07 Page 2
DVBHQUP ;ALB/JLU This routine is used for the upload option. ; 3/9/06 4:16pm
+1 ;;4.0;HINQ;**12,49,56**;03/25/92
A DO A^DVBHUTIL
B WRITE !
B1 READ !,"Do you want to examine the Suspense file by 'P'atient or 'A'll P// ",K1:DTIME
if '$TEST
GOTO KA1
if "Pp"[K1!(K1="")
DO P
if "Aa"[$EXTRACT(K1_1)
DO L
+1 if DVBOUT="^"
GOTO KA1
+2 IF K1="?"!(K1'="^")
WRITE !!,*7,?15,"Answer with capital A or P <RET> also for P",!!
GOTO B1
KA1 DO KA1^DVBHQEDT
QUIT
KA DO KA^DVBHQEDT
+1 QUIT
P SET K1="^"
KILL DVBDIQ
DO P1
IF Y<0
SET DVBOUT="^"
QUIT
+1 NEW DVBQT,DVBTMP1,DVBTMP2
+2 SET DIE="^DPT("
SET (DA,DFN)=+Y
SET DR="[DVBHINQ UPDATE]"
SET DVBJ2=0
DO TEM^DVBHIQR
+3 IF '$DATA(DVBERCS)
DO CHKID^DVBHQD1
+4 IF $GET(DVBQT)
Begin DoDot:1
+5 SET DVBTMP1=$GET(DVBNOALR)
+6 SET DVBTMP2=$GET(DVBJ2)
+7 SET DVBNOALR=";4///a;5////"_DUZ_";6///N"
SET DVBJ2=1
DO FILE
+8 SET DVBNOALR=DVBTMP1
+9 SET DVBJ2=DVBTMP2
End DoDot:1
GOTO P
+10 if '$DATA(DVBERCS)
DO ^DIE
KILL DIE,DR,DA
+11 DO C
IF DVBOUT'="^"
GOTO P
+12 QUIT
L SET ANS=""
SET K1="^"
+1 IF '$DATA(^DVB(395.5,"AC","N"))
WRITE !!,"No patients to be updated."
HANG 3
QUIT
+2 FOR K2=0:0
SET K2=$ORDER(^DVB(395.5,"AC","N",K2))
if 'K2!(DVBOUT="^")
QUIT
Begin DoDot:1
+3 IF $DATA(^DVB(395.5,K2,"RS",0))
IF $PIECE(^DVB(395.5,K2,0),U,5)'="Y"
IF $PIECE(^(0),U,5)'="I"
Begin DoDot:2
+4 SET DIE="^DPT("
SET (DA,DFN)=K2
SET DR="[DVBHINQ UPDATE]"
SET DVBJ2=0
DO TEM^DVBHIQR
+5 NEW DVBQT,DVBTMP1,DVBTMP2
+6 SET DVBQT=1
+7 IF '$DATA(DVBERCS)
DO CHKID^DVBHQD1
IF DVBQT
Begin DoDot:3
+8 SET DVBTMP1=$GET(DVBNOALR)
+9 SET DVBTMP2=$GET(DVBJ2)
+10 SET DVBNOALR=";4///a;5////"_DUZ_";6///N"
SET DVBJ2=1
DO FILE
+11 SET DVBNOALR=DVBTMP1
+12 SET DVBJ2=DVBTMP2
End DoDot:3
QUIT
+13 if '$DATA(DVBERCS)
DO ^DIE
DO C
DO KA
if DVBOUT="^"
QUIT
End DoDot:2
End DoDot:1
+14 QUIT
C ;SETS UPDATED? FIELD, RUNS INCONSIS. CHECKER.
+1 if DVBOUT["^"
QUIT
SET DVB=DFN
SET DVBLP=2
SET DVBMM=1
SET DVBMM2=1
DO QB^DVBHQZ6
+2 if 'DVBJ2
QUIT
IF DVBJ2
SET $PIECE(^DVB(395.5,DFN,0),U,5)="Y"
SET DGEDCN=1
DO ^DGRPC
IF 1
+3 IF '$TEST
SET $PIECE(^DVB(395.5,DFN,0),U,5)="N"
+4 DO FILE
KILL DVBDIQ
QUIT
+5 ;
+6 ;I '$D(^DVB(395.7,DFN,0)) K DIC,DD,DO S DIC(0)="LQ",DIC="^DVB(395.7,",DIC("DR")="1////"_DUZ_";2///"_"N",(X,DINUM)=DFN D FILE^DICN I 1
+7 ;E S DIE="^DVB(395.7,",DA=DFN,DR="1////"_DUZ_";2///"_"N" D ^DIE
+8 ;
FILE IF '$DATA(^DVB(395.7,DFN,0))
Begin DoDot:1
+1 KILL DIC,DD,DO
SET DIC(0)="LQ"
SET DIC="^DVB(395.7,"
+2 SET DIC("DR")="1////"_DUZ_";2///"_"N"_$SELECT($DATA(DVBNOALR):DVBNOALR,1:"")
+3 SET (X,DINUM)=DFN
DO FILE^DICN
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 KILL DIC
SET (DIC,DIE)="^DVB(395.7,"
SET DA=DFN
+6 SET DR="1////"_DUZ_";2///"_"N"_$SELECT($DATA(DVBNOALR):DVBNOALR,1:"")
+7 IF 'DVBJ2
IF $DATA(DVBNOALR)
IF DVBNOALR]""
SET DR=$EXTRACT(DVBNOALR,2,99)
+8 LOCK +^DVB(395.7,DFN):3
IF $TEST
DO ^DIE
+9 LOCK -^DVB(395.7,DFN)
End DoDot:1
+10 KILL DIC,DIE,DA,DR
QUIT
+11 ;
+12 ;ENRTY PT FOR PRINT OPTION
PT WRITE @$SELECT('$DATA(IOF):"#",IOF="":"#",1:IOF),!!!!!!!!!!
PT1 READ "Do you want a print out of a (S)ingle patient or (A)ll of the patients? S// ",DVBJA:DTIME
if '$TEST
GOTO KA1
if DVBJA="S"!(DVBJA="")
DO S
if DVBJA="A"
DO T
+1 IF DVBJA="?"!(DVBJA'="^")
WRITE !!,*7,?15,"Answer with a capital A or S or <RET> for S",!!
GOTO PT1
+2 DO KA1
QUIT
S DO P1
IF Y<0
SET DVBJA="^"
QUIT
+1 SET (DFN,D0,ZTSAVE("D0"),ZTSAVE("DFN"))=+Y
SET ZTRTN="S1^DVBHQUP"
DO RP
IF $DATA(IO("Q"))!POP
SET DVBJA="^"
QUIT
S1 USE IO
DO TEM^DVBHIQR
if '$DATA(DVBERCS)
DO ^DVBHCG
IF '$DATA(ZTSK)
XECUTE ^%ZIS("C")
+1 SET DVBJA="^"
QUIT
T SET DVBJA="^"
SET ZTRTN="RP1^DVBHQUP"
+1 WRITE !!,?6,"Select one of the following:",!!,?11,"1 Updated",!,?11,"2 NOT Updated",!,?11,"3 Both",!,"How would you like your print sorted? Updated//"
+2 READ Y:DTIME
if Y="^"!('$TEST)
QUIT
+3 SET (ZTSAVE("DVBY"),DVBY)=$SELECT(Y=1!(Y="")!(Y["U"):1,Y=2!(Y["N"):2,Y=3!(Y["B"):3,1:"")
+4 IF DVBY=""
WRITE !!,*7,"Answer with a code from the list."
GOTO T
+5 DO CT
QUIT
+6 ;
AU ;ENTRY POINT FOR DISPLAY OF AUDIT.
+1 WRITE @$SELECT('$DATA(IOF):"#",IOF="":"#",1:IOF),!!!!!
AU1 WRITE !!,?6,"Select one of the following:",!!,?11,"1 Patient",!,?11,"2 User",!,?11,"3 Date/Time",!,"By which would you like the sort to begin? : Patient//"
+1 READ Y:DTIME
if Y="^"!('$TEST)
QUIT
+2 SET (FLDS,BY)=$SELECT(Y=1!(Y="")!(Y["P"):"[DVBHINQ AUDIT/PAT]",Y=2!(Y["U"):"[DVBHINQ AUDIT/USER]",Y=3!(Y["D"):"[DVBHINQ AUDIT/DT]",1:"")
+3 IF BY=""
WRITE !!,*7,"Answer with a code from the above list."
GOTO AU1
+4 SET L=0
SET DIC="^DVB(395.7,"
SET (FR,TO)=""
DO EN1^DIP
QUIT
+5 ;
P1 WRITE !
DO KA
SET DIC="^DVB(395.5,"
SET DIC(0)="AEMZQ"
SET DIC("S")="I ($P(^(0),U,4)=""N""),($D(^(""RS"",0)))"
SET DIC("A")="Select Patient from ""HINQ Suspense file"":"
DO ^DIC
KILL DIC
QUIT
+1 ;
RP SET %IS="MQ"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
SET ZTDESC="This is a job for the HINQ report."
SET ZTIO=ION
DO ^%ZTLOAD
XECUTE ^%ZIS("C")
QUIT
+1 if DVBJA=""!(DVBJA="S")
QUIT
RP1 SET DVB8=""
USE IO
FOR D0=0:0
SET (D0,DFN)=$ORDER(^DVB(395.5,"AC","N",D0))
if 'D0
QUIT
SET DVBJ1=$SELECT((DVBY=1)&($PIECE(^DVB(395.5,D0,0),U,5)="Y"):1,(DVBY=2)&($PIECE(^(0),U,5)'="Y"):1,DVBY=3:1,1:0)
if DVBJ1
DO TEM^DVBHIQR
if '$DATA(DVBERCS)
DO ^DVBHCG
if DVB8["^"
QUIT
DO KA
+1 IF '$DATA(ZTSK)
XECUTE ^%ZIS("C")
+2 QUIT
+3 ;
CT SET DVB1=0
FOR DVB=0:0
SET DVB1=$ORDER(^DVB(395.5,"AC","N",DVB1))
if 'DVB1
QUIT
SET DVB=$SELECT(DVBY=1&($PIECE(^DVB(395.5,DVB1,0),U,5)="Y"):DVB+1,DVBY=2&($PIECE(^(0),U,5)'="Y"):DVB+1,DVBY=3:DVB+1,1:DVB)
+1 IF 'DVB
WRITE !,"There are no patients at this time for this print."
QUIT
CT1 WRITE !!,"There are ",DVB," patients for this report, do you wish to continue"
SET %=1
DO YN^DICN
if %=2!(%<0)
QUIT
IF '%
WRITE !,"A YES answer will continue on with the report, answer with Y or N"
GOTO CT1
+1 DO RP
QUIT
LSTR ;lists the SC disabilities in the ReviewPatient vs. HINQ data
+1 ;option, [DVB HUPLOAD-PRINT]
+2 ;called from print template [DVBHINQ PAT-HINQ COMP]
+3 NEW DVBIEN
+4 KILL DVBERR
+5 DO GETS^DIQ(2,DFN_",",".302;.3014;.3721*","EI","DVBDIQ","DVBERR")
+6 WRITE "-Comb. SC%: "_+DVBDIQ(2,DFN_",",.302,"E")_" "
+7 WRITE "Eff. Date Comb. Eval.: "_DVBDIQ(2,DFN_",",.3014,"E")
+8 IF $PIECE($GET(^DPT(DFN,.372,0)),U,3)>0
DO LABELS^DVBHS3
+9 SET LP=""
+10 IF $DATA(DVBDIQ(2.04))
FOR
SET LP=$ORDER(DVBDIQ(2.04,LP))
if 'LP
QUIT
Begin DoDot:1
+11 IF ($Y+5)>IOSL
IF $EXTRACT(IOST,1,2)="C-"
DO PAUSE^DVBHS3
+12 WRITE !,$EXTRACT(DVBDIQ(2.04,LP,.01,"E"),1,40),?42,DVBDIQ(2.04,LP,2,"E")
+13 WRITE ?50,$GET(DVBDIQ(2.04,LP,4,"I")),?55,$GET(DVBDIQ(2.04,LP,5,"E"))
+14 WRITE ?68,$GET(DVBDIQ(2.04,LP,6,"E"))
End DoDot:1
+15 QUIT
+16 NEW DVBFR,DVBLAST,DVBX,QUIT
+17 SET DVBFR=""
+18 SET DVBLAST=$ORDER(^DPT(DFN,.372,""),-1)
+19 IF $GET(DVBLAST)']""
QUIT
+20 FOR DVBX=0:0
DO LOOP
IF $GET(QUIT)=1!(DVBFR(2)>DVBLAST)
KILL QUIT
QUIT
+21 QUIT
LOOP ;
+1 DO LIST
+2 NEW DVBCT
+3 FOR DVBCT=0:0
SET DVBCT=$ORDER(DVBARR("DILIST",DVBCT))
if 'DVBCT!(DVBCT>19)
QUIT
Begin DoDot:1
+4 WRITE !?36,$PIECE(DVBARR("DILIST",DVBCT,0),U,2),?68,$PIECE(DVBARR("DILIST",DVBCT,0),U,4),?74,$PIECE(DVBARR("DILIST",DVBCT,0),U,5)
End DoDot:1
+5 DO PAUSE^DVBHS3
+6 QUIT
LIST ;
+1 DO LIST^DIC(2.04,","_DFN_",",".01;2;3","P",20,.DVBFR,,,,,"DVBARR",)
+2 IF $GET(DVBFR(2))'>0
SET QUIT=1
+3 QUIT
