- 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 Mar 13, 2025@21:03:52 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
