DVBHQUS ;ISC-ALBANY/PKE-CHECK STATUS in suspense ; 04 OCT 85 4:07 pm
;;4.0;HINQ;**31**;03/25/92
LK S X=0,DIC="^DPT(",DIC(0)="AEMQ" D ^DIC Q:Y'>0 S X=+Y
UP I X S DIC="^DVB(395.5,",DIC(0)="NQ" D ^DIC S DFN=+Y I Y'>0 W !,?22,"Patient not in Suspense file" G LK
Q
FIND D LK I Y>0 D UP I Y>0 S Y0=$Y,Y1=0 S IOP="HOME" D ^%ZIS K IOP D CODE W !! D WRTMESS,VER K Y0,R,R1 G FIND
;
K DVBIXMZ
EX K DIC,I,DVBLN,DVBUSER,DVBI,DFN,R,R1,Y,Y0,Y1,X,Y,Z,C,G,DR,DIC,DA,D0 QUIT
Q
FILM ;
S DFN=D0 S Y0=$Y D CODE W !! D WRTMESS Q
Q
CODE Q:'$D(DFN) F G=3,4,5 I $D(^DD(395.5,G,0)) S R(G)=$P(^(0),U)
S R(8)="Last Updated",Y1="" I $D(^DVB(395.7,DFN,0)) S Y1=$P(^(0),U,3)
Q:'$D(^DVB(395.5,DFN,0)) S Y=$P(^(0),U,3),Z=$P(^(0),U,4),Y0=$P(^(0),U,6),DVBI=$P(^(0),U,5),DVBI=$S(DVBI="Y":"YES",1:"NO"),Z=$S(Z="P":"Pending",Z="N":"NEWMAIL",Z="E":"Error",Z="V":"IDCU Error",Z="A":"Abbreviated",1:"")
D TM W @IOF S Y0=$Y W !!,R(3),": ",Y,?46,R(4),?61,": ",Z
S Y=Y1 D TM S Y1=Y W !,R(5),?21,": ",DVBI,?46,R(8),?61,": ",Y1
K R1 F DVBUSER=0:0 S DVBUSER=$O(^DVB(395.5,DFN,1,DVBUSER)) Q:'DVBUSER S:$D(^DVB(395.5,DFN,1,DVBUSER,0)) R1(DVBUSER)=$P(^(0),U,2)
USER F DVBUSER=0:0 S DVBUSER=$O(R1(DVBUSER)) Q:'DVBUSER I $D(^VA(200,DVBUSER,0)) W !,"REQUESTED BY",?21,": ",$E($P(^(0),U,1),1,23),?46 S Y=R1(DVBUSER) D TM W "TIME OF REQUEST",?61,": ",Y
Q
TM S Y=$E(Y,1,12),Y=$$FMTE^XLFDT(Y,"5F"),Y=$TR(Y," ","0") Q
;
WRTMESS Q:'$D(^DVB(395.5,$S($D(DFN):DFN,1:0),0)) S DVBIXMZ=$P(^(0),U,7) Q:'DVBIXMZ
S:'$D(Y0) Y0=$Y
Q:'$D(^XMB(3.9,DVBIXMZ,0)) S Y=$P(^(0),U,3) D TM W $P(^(0),U)," ",Y,!
F DVBLN=1:1 Q:'$D(^XMB(3.9,DVBIXMZ,2,DVBLN,0)) W $E(^(0),1,80),! W:$L(^(0))>80 $E(^(0),81,150),! W:$L(^(0))>150 $E(^(0),151,226),! D:($Y-Y0)>(IOSL-3-Y1) SCROL Q:X="^" D:$Y<Y0 ABS
K DVBSCROL Q
ABS S Y0=255-Y0 Q:$Y+Y0<(IOSL-3-Y1)
SCROL I $E(IOST,1)["C" W !,"Press return to continue "_$C(7) R X:DTIME Q:'$T!(X="^") S Y0=$Y,Y1=0 W ! Q
I $E(IOST,1)'["C",$Y>64 W @IOF Q
Q
VER Q:X["^" I $D(^DPT(DFN,.361)) S Z=$P(^(.361),"^",1) W !,?10,"***ELIGIBILITY ",$S(Z="P":"PENDING VERIFICATION",Z="R":"PENDING RE-VERIFICATION",Z="V":"VERIFIED",1:"NOT VERIFIED"),"***",! Q
W !!,?10,"***ELIGIBILITY NOT VERIFIED***",! Q
;
EN D LK I Y>0 D UP I Y>0 S DR="0:99",DIC="^DVB(395.5,",DA=DFN D VER,EN^DIQ G EN
G EX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHQUS 2295 printed Sep 23, 2025@19:35:08 Page 2
DVBHQUS ;ISC-ALBANY/PKE-CHECK STATUS in suspense ; 04 OCT 85 4:07 pm
+1 ;;4.0;HINQ;**31**;03/25/92
LK SET X=0
SET DIC="^DPT("
SET DIC(0)="AEMQ"
DO ^DIC
if Y'>0
QUIT
SET X=+Y
UP IF X
SET DIC="^DVB(395.5,"
SET DIC(0)="NQ"
DO ^DIC
SET DFN=+Y
IF Y'>0
WRITE !,?22,"Patient not in Suspense file"
GOTO LK
+1 QUIT
FIND DO LK
IF Y>0
DO UP
IF Y>0
SET Y0=$Y
SET Y1=0
SET IOP="HOME"
DO ^%ZIS
KILL IOP
DO CODE
WRITE !!
DO WRTMESS
DO VER
KILL Y0,R,R1
GOTO FIND
+1 ;
+2 KILL DVBIXMZ
EX KILL DIC,I,DVBLN,DVBUSER,DVBI,DFN,R,R1,Y,Y0,Y1,X,Y,Z,C,G,DR,DIC,DA,D0
QUIT
+1 QUIT
FILM ;
+1 SET DFN=D0
SET Y0=$Y
DO CODE
WRITE !!
DO WRTMESS
QUIT
+2 QUIT
CODE if '$DATA(DFN)
QUIT
FOR G=3,4,5
IF $DATA(^DD(395.5,G,0))
SET R(G)=$PIECE(^(0),U)
+1 SET R(8)="Last Updated"
SET Y1=""
IF $DATA(^DVB(395.7,DFN,0))
SET Y1=$PIECE(^(0),U,3)
+2 if '$DATA(^DVB(395.5,DFN,0))
QUIT
SET Y=$PIECE(^(0),U,3)
SET Z=$PIECE(^(0),U,4)
SET Y0=$PIECE(^(0),U,6)
SET DVBI=$PIECE(^(0),U,5)
SET DVBI=$SELECT(DVBI="Y":"YES",1:"NO")
SET Z=$SELECT(Z="P":"Pending",Z="N":"NEWMAIL",Z="E":"Error",Z="V":"IDCU Error",Z="A":"Abbreviated",1:"")
+3 DO TM
WRITE @IOF
SET Y0=$Y
WRITE !!,R(3),": ",Y,?46,R(4),?61,": ",Z
+4 SET Y=Y1
DO TM
SET Y1=Y
WRITE !,R(5),?21,": ",DVBI,?46,R(8),?61,": ",Y1
+5 KILL R1
FOR DVBUSER=0:0
SET DVBUSER=$ORDER(^DVB(395.5,DFN,1,DVBUSER))
if 'DVBUSER
QUIT
if $DATA(^DVB(395.5,DFN,1,DVBUSER,0))
SET R1(DVBUSER)=$PIECE(^(0),U,2)
USER FOR DVBUSER=0:0
SET DVBUSER=$ORDER(R1(DVBUSER))
if 'DVBUSER
QUIT
IF $DATA(^VA(200,DVBUSER,0))
WRITE !,"REQUESTED BY",?21,": ",$EXTRACT($PIECE(^(0),U,1),1,23),?46
SET Y=R1(DVBUSER)
DO TM
WRITE "TIME OF REQUEST",?61,": ",Y
+1 QUIT
TM SET Y=$EXTRACT(Y,1,12)
SET Y=$$FMTE^XLFDT(Y,"5F")
SET Y=$TRANSLATE(Y," ","0")
QUIT
+1 ;
WRTMESS if '$DATA(^DVB(395.5,$SELECT($DATA(DFN)
QUIT
SET DVBIXMZ=$PIECE(^(0),U,7)
if 'DVBIXMZ
QUIT
+1 if '$DATA(Y0)
SET Y0=$Y
+2 if '$DATA(^XMB(3.9,DVBIXMZ,0))
QUIT
SET Y=$PIECE(^(0),U,3)
DO TM
WRITE $PIECE(^(0),U)," ",Y,!
+3 FOR DVBLN=1:1
if '$DATA(^XMB(3.9,DVBIXMZ,2,DVBLN,0))
QUIT
WRITE $EXTRACT(^(0),1,80),!
if $LENGTH(^(0))>80
WRITE $EXTRACT(^(0),81,150),!
if $LENGTH(^(0))>150
WRITE $EXTRACT(^(0),151,226),!
if ($Y-Y0)>(IOSL-3-Y1)
DO SCROL
if X="^"
QUIT
if $Y<Y0
DO ABS
+4 KILL DVBSCROL
QUIT
ABS SET Y0=255-Y0
if $Y+Y0<(IOSL-3-Y1)
QUIT
SCROL IF $EXTRACT(IOST,1)["C"
WRITE !,"Press return to continue "_$CHAR(7)
READ X:DTIME
if '$TEST!(X="^")
QUIT
SET Y0=$Y
SET Y1=0
WRITE !
QUIT
+1 IF $EXTRACT(IOST,1)'["C"
IF $Y>64
WRITE @IOF
QUIT
+2 QUIT
VER if X["^"
QUIT
IF $DATA(^DPT(DFN,.361))
SET Z=$PIECE(^(.361),"^",1)
WRITE !,?10,"***ELIGIBILITY ",$SELECT(Z="P":"PENDING VERIFICATION",Z="R":"PENDING RE-VERIFICATION",Z="V":"VERIFIED",1:"NOT VERIFIED"),"***",!
QUIT
+1 WRITE !!,?10,"***ELIGIBILITY NOT VERIFIED***",!
QUIT
+2 ;
EN DO LK
IF Y>0
DO UP
IF Y>0
SET DR="0:99"
SET DIC="^DVB(395.5,"
SET DA=DFN
DO VER
DO EN^DIQ
GOTO EN
+1 GOTO EX
