DVBACRRR ;ALB/GTS-557/THM-REPRINT 21-DAY CERT FOR THE RO ;21 JUL 89
;;2.7;AMIE;**42**;Apr 10, 1995
;
D INIT
I CONT=0 G KIL
D HDR
S DVBSEL=$$SELECT^DVBAUTL5("ORIGINAL PROCESSING DATE","21 Day Certificate")
I DVBSEL="D" S SDATE=$$DATE^DVBACRRP G:SDATE<0 KIL
I DVBSEL="N" S XDA=$$PAT^DVBAUTL5("RO") G:XDA<1 KIL
I DVBSEL=0 G KIL
I 'CONT G KIL
D DEVICE
I 'CONT G KIL
D DATA
KIL D KILL
Q
;
DEVICE ;
S VAR(1,0)="0,0,0,2:0,0^"
D WR^DVBAUTL4("VAR")
K VAR
S %ZIS="AEQ"
D ^%ZIS
K %ZIS
I POP S CONT=0 Q
I $D(IO("Q")) DO
.S CONT=0
.S ZTIO=ION,ZTDESC="21-day Cert reprint",ZTRTN="DATA^DVBACRRR"
.F I="DVBSEL","XDA","DVBAD2","FDT(0)","HD","HD1","SDATE","NODTA" S ZTSAVE(I)=""
.D ^%ZTLOAD
.D ^%ZISC
.I $D(ZTSK) DO
..S VAR(1,0)="0,0,0,2:2,0^Request queued."
..D WR^DVBAUTL4("VAR")
..K VAR
..Q
.Q
Q
;
DATA ;
I DVBSEL="D" DO ;by date range
.U IO
.F XDA=0:0 S XDA=$O(^DVB(396,"AC",DVBAD2,"P",XDA)) Q:XDA="" S DFN=$P(^DVB(396,XDA,0),U,1) I $P(^(4),U,4)=SDATE D CREATE
.Q
I DVBSEL="N" DO ;by name/ssn
.S DFN=$P(^DVB(396,XDA,0),U,1)
.D CREATE
.Q
I NODTA=0 DO ;no data found
.S VAR(1,0)="0,0,0,2:2,0^No data found to reprint"
.D WR^DVBAUTL4("VAR")
.K VAR
.Q
;
KILL K DVBAON2,DVBSEL,VAR,DVBAD2,CONT
Q:$G(DVBGUI) D:$D(ZTQUEUED) KILL^%ZTLOAD
D KILL^DVBAUTIL
Q
;
CREATE ;CERTIFICATE CREATE
I $D(^DVB(396,XDA,2)) Q:$P(^(2),U,10)="L"
I '$D(^DPT(DFN,0)) W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF
I '$D(^DPT(DFN,0)) W !!,"Patient record missing for DFN ",DFN,!!
I '$D(^DPT(DFN,0)) S DVBAON2="" Q
S PNAM=$P(^DPT(DFN,0),U,1),SSN=$P(^(0),U,9),CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Unknown")
S WARD=$P(^DVB(396,XDA,4),U,6),BED=$P(^(4),U,7),DCHGDT=$P(^(4),U,5),ADMDT=$P(^(0),U,4)
U IO W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF
W !,FDT(0),?32,"REPORT OF CONTACT",!,?31,"21-DAY CERTIFICATE",?(80-11),"PAGE: 1",!,?(80-$L(HD1)\2),HD1,!!!!!!!,"Patient name: ",?16,PNAM,!,?9,"SSN: ",?16,SSN,?33,"Claim #: ",?43,CNUM,!!,?9,"Ward: ",?16,WARD,?30,"Bed: ",?36,BED,!!!
W " The patient above has been hospitalized for 21 consecutive days ",!,"from " S Y=ADMDT X ^DD("DD") W Y," to " S Y=DCHGDT X ^DD("DD") W Y,", and the major diagnosis for",!,"this period is:",!!!
K ^UTILITY($J,"W")
F LINE=0:0 S LINE=$O(^DVB(396,XDA,3,LINE)) Q:LINE="" S X=^(LINE,0),DIWL=5,DIWR=75,DIWF="NW" D ^DIWP
D ^DIWW W !!!,"A signed copy of this document is on file at "_HD1,!
W !!?5,"R0C 119",!
S NODTA=1,DVBAON2=""
Q
;
HDR ;Displays the header to this option.
S VAR(1,0)="0,0,(IOM-$L(HD)\2),1:3,1:0^"_HD
D WR^DVBAUTL4("VAR")
K VAR
S VAR(1,0)="0,0,0,0:2,0^This program REPRINTS 21-day certificates for the RO."
D WR^DVBAUTL4("VAR")
K VAR
Q
;
INIT ;sets up and checks various variables
S CONT=1
D DUZ2^DVBAUTIL
I $D(DVBAQUIT) S CONT=0
I $D(DUZ)#2=0 DO
.S VAR(1,0)="1,0,0,2:2,0^Your USER NUMBER is missing. Call the site manager."
.D WR^DVBAUTL4("VAR")
.K VAR
.I '$D(DVBGUI) D PAUSE^DVBCUTL4
.S CONT=0
.Q
I CONT=0 Q
S NODTA=0,HD="REGIONAL OFFICE 21-DAY CERTIFICATE REPRINTING"
I '$D(DVBGUI) D HOME^%ZIS
D NOPARM^DVBAUTL2
I $D(DVBAQUIT) S CONT=0
S HD1=$$SITE^DVBCUTL4
I '$D(DT) S X="T" D ^%DT S DT=Y
S Y=DT X ^DD("DD") S FDT(0)=Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBACRRR 3266 printed Apr 09, 2024@20:48:42 Page 2
DVBACRRR ;ALB/GTS-557/THM-REPRINT 21-DAY CERT FOR THE RO ;21 JUL 89
+1 ;;2.7;AMIE;**42**;Apr 10, 1995
+2 ;
+3 DO INIT
+4 IF CONT=0
GOTO KIL
+5 DO HDR
+6 SET DVBSEL=$$SELECT^DVBAUTL5("ORIGINAL PROCESSING DATE","21 Day Certificate")
+7 IF DVBSEL="D"
SET SDATE=$$DATE^DVBACRRP
if SDATE<0
GOTO KIL
+8 IF DVBSEL="N"
SET XDA=$$PAT^DVBAUTL5("RO")
if XDA<1
GOTO KIL
+9 IF DVBSEL=0
GOTO KIL
+10 IF 'CONT
GOTO KIL
+11 DO DEVICE
+12 IF 'CONT
GOTO KIL
+13 DO DATA
KIL DO KILL
+1 QUIT
+2 ;
DEVICE ;
+1 SET VAR(1,0)="0,0,0,2:0,0^"
+2 DO WR^DVBAUTL4("VAR")
+3 KILL VAR
+4 SET %ZIS="AEQ"
+5 DO ^%ZIS
+6 KILL %ZIS
+7 IF POP
SET CONT=0
QUIT
+8 IF $DATA(IO("Q"))
Begin DoDot:1
+9 SET CONT=0
+10 SET ZTIO=ION
SET ZTDESC="21-day Cert reprint"
SET ZTRTN="DATA^DVBACRRR"
+11 FOR I="DVBSEL","XDA","DVBAD2","FDT(0)","HD","HD1","SDATE","NODTA"
SET ZTSAVE(I)=""
+12 DO ^%ZTLOAD
+13 DO ^%ZISC
+14 IF $DATA(ZTSK)
Begin DoDot:2
+15 SET VAR(1,0)="0,0,0,2:2,0^Request queued."
+16 DO WR^DVBAUTL4("VAR")
+17 KILL VAR
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
DATA ;
+1 ;by date range
IF DVBSEL="D"
Begin DoDot:1
+2 USE IO
+3 FOR XDA=0:0
SET XDA=$ORDER(^DVB(396,"AC",DVBAD2,"P",XDA))
if XDA=""
QUIT
SET DFN=$PIECE(^DVB(396,XDA,0),U,1)
IF $PIECE(^(4),U,4)=SDATE
DO CREATE
+4 QUIT
End DoDot:1
+5 ;by name/ssn
IF DVBSEL="N"
Begin DoDot:1
+6 SET DFN=$PIECE(^DVB(396,XDA,0),U,1)
+7 DO CREATE
+8 QUIT
End DoDot:1
+9 ;no data found
IF NODTA=0
Begin DoDot:1
+10 SET VAR(1,0)="0,0,0,2:2,0^No data found to reprint"
+11 DO WR^DVBAUTL4("VAR")
+12 KILL VAR
+13 QUIT
End DoDot:1
+14 ;
KILL KILL DVBAON2,DVBSEL,VAR,DVBAD2,CONT
+1 if $GET(DVBGUI)
QUIT
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+2 DO KILL^DVBAUTIL
+3 QUIT
+4 ;
CREATE ;CERTIFICATE CREATE
+1 IF $DATA(^DVB(396,XDA,2))
if $PIECE(^(2),U,10)="L"
QUIT
+2 IF '$DATA(^DPT(DFN,0))
if (IOST?1"C-".E)!($DATA(DVBAON2))
WRITE @IOF
+3 IF '$DATA(^DPT(DFN,0))
WRITE !!,"Patient record missing for DFN ",DFN,!!
+4 IF '$DATA(^DPT(DFN,0))
SET DVBAON2=""
QUIT
+5 SET PNAM=$PIECE(^DPT(DFN,0),U,1)
SET SSN=$PIECE(^(0),U,9)
SET CNUM=$SELECT($DATA(^DPT(DFN,.31)):$PIECE(^(.31),U,3),1:"Unknown")
+6 SET WARD=$PIECE(^DVB(396,XDA,4),U,6)
SET BED=$PIECE(^(4),U,7)
SET DCHGDT=$PIECE(^(4),U,5)
SET ADMDT=$PIECE(^(0),U,4)
+7 USE IO
if (IOST?1"C-".E)!($DATA(DVBAON2))
WRITE @IOF
+8 WRITE !,FDT(0),?32,"REPORT OF CONTACT",!,?31,"21-DAY CERTIFICATE",?(80-11),"PAGE: 1",!,?(80-$LENGTH(HD1)\2),HD1,!!!!!!!,"Patient name: ",?16,PNAM,!,?9,"SSN: ",?16,SSN,?33,"Claim #: ",?43,CNUM,!!,?9,"Ward: ",?16,WARD,?30,"Bed: ",?36,BED,!!!
+9 WRITE " The patient above has been hospitalized for 21 consecutive days ",!,"from "
SET Y=ADMDT
XECUTE ^DD("DD")
WRITE Y," to "
SET Y=DCHGDT
XECUTE ^DD("DD")
WRITE Y,", and the major diagnosis for",!,"this period is:",!!!
+10 KILL ^UTILITY($JOB,"W")
+11 FOR LINE=0:0
SET LINE=$ORDER(^DVB(396,XDA,3,LINE))
if LINE=""
QUIT
SET X=^(LINE,0)
SET DIWL=5
SET DIWR=75
SET DIWF="NW"
DO ^DIWP
+12 DO ^DIWW
WRITE !!!,"A signed copy of this document is on file at "_HD1,!
+13 WRITE !!?5,"R0C 119",!
+14 SET NODTA=1
SET DVBAON2=""
+15 QUIT
+16 ;
HDR ;Displays the header to this option.
+1 SET VAR(1,0)="0,0,(IOM-$L(HD)\2),1:3,1:0^"_HD
+2 DO WR^DVBAUTL4("VAR")
+3 KILL VAR
+4 SET VAR(1,0)="0,0,0,0:2,0^This program REPRINTS 21-day certificates for the RO."
+5 DO WR^DVBAUTL4("VAR")
+6 KILL VAR
+7 QUIT
+8 ;
INIT ;sets up and checks various variables
+1 SET CONT=1
+2 DO DUZ2^DVBAUTIL
+3 IF $DATA(DVBAQUIT)
SET CONT=0
+4 IF $DATA(DUZ)#2=0
Begin DoDot:1
+5 SET VAR(1,0)="1,0,0,2:2,0^Your USER NUMBER is missing. Call the site manager."
+6 DO WR^DVBAUTL4("VAR")
+7 KILL VAR
+8 IF '$DATA(DVBGUI)
DO PAUSE^DVBCUTL4
+9 SET CONT=0
+10 QUIT
End DoDot:1
+11 IF CONT=0
QUIT
+12 SET NODTA=0
SET HD="REGIONAL OFFICE 21-DAY CERTIFICATE REPRINTING"
+13 IF '$DATA(DVBGUI)
DO HOME^%ZIS
+14 DO NOPARM^DVBAUTL2
+15 IF $DATA(DVBAQUIT)
SET CONT=0
+16 SET HD1=$$SITE^DVBCUTL4
+17 IF '$DATA(DT)
SET X="T"
DO ^%DT
SET DT=Y
+18 SET Y=DT
XECUTE ^DD("DD")
SET FDT(0)=Y
+19 QUIT
