DVBACERT ;ALB/GTS-557/THM - 21 DAY CERT CHECKER ;1/23/91 11:17 AM
;;2.7;AMIE;**5,203**;Apr 10, 1995;Build 16
;
K ^TMP($J) S DVBAMAN=""
S HD="MANUAL 21 DAY CERTIFICATE PROCESSING" D HOME^%ZIS
I '$D(DT) S X="T" D ^%DT S DT=Y
W @IOF,!?(IOM-$L(HD)\2),HD,!!,"This program should be run only if the Task Manager fails.",!!!
S %ZIS="AEQ" D ^%ZIS K %ZIS G:POP KILL
I $D(IO("Q")) S ZTIO=ION,ZTDESC="Manual 21-day Cert program",ZTRTN="DATA^DVBACERT" F I="HD","HD1","DVBAMAN" S ZTSAVE(I)=""
I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued.",!! G KILL
G DATA
;
CHK S ADMDT=$E($P(^DVB(396,XDA,0),U,4),1,12),DFN=$P(^(0),U,1),STAT=$P(^(1),U,12) Q:STAT]"" ; *203 - don't include seconds in admission date
;K TEMP F I=0:0 S I=$O(^DGPM("APTT1",DFN,I)) Q:I="" F J=0:0 S J=$O(^DGPM("APTT1",DFN,I,J)) Q:J="" S ZJ=$S($D(^DGPM(J,0)):^(0),1:"") I ZJ]"" S TEMP(+$E(I,1,14),DFN)=J_U_+$E(I,1,14) ; *203
K TEMP F I=0:0 S I=$O(^DGPM("APTT1",DFN,I)) Q:I="" F J=0:0 S J=$O(^DGPM("APTT1",DFN,I,J)) Q:J="" S ZJ=$S($D(^DGPM(J,0)):^(0),1:"") I ZJ]"" S TEMP(+$E(I,1,12),DFN)=J_U_+$E(I,1,12) ; *203 - Don't include seconds in date
S DCHGDT="" I $D(TEMP(ADMDT,DFN)) D CHK1
I DCHGDT]"" D LOS^DVBAUTIL I LOS'<21 S ^TMP($J,ADMDT,MB,DFN)=XDA_U_DCHGDT_U_$P(TEMP(ADMDT,DFN),U,2) Q ;**Dischrgd, stay >21 days
I DCHGDT]"" D LOS^DVBAUTIL I LOS<21 S DR="6.5////C;6.8////"_DT_";6.9////"_"Not applicable",DA=XDA,DIE="^DVB(396," D ^DIE K DA Q ;**Dchgd, stay <21
Q
;
LOOK1 S XDA=$P(^TMP($J,ADMDT,LADM,DFN),U,1),DCHGDT=$P(^(DFN),U,2) D CREATE
Q
;
CHK1 S MB=$P(TEMP(ADMDT,DFN),U,1),DCHPTR=+$P(^DGPM(MB,0),U,17)
S DCHGDT=$S($D(^DGPM(DCHPTR,0)):$P(^(0),U,1),1:"") I DCHGDT="" S DCHGDT=DT D LOS^DVBAUTIL S DCHGDT="" I LOS'<21 S ^TMP($J,ADMDT,MB,DFN)=XDA_U_DT_U_$P(TEMP(ADMDT,DFN),U,2) Q
;null DCHGDT/use DT if vet still in hosp
;** If vet not discharged, DCHGDT="" on Quit
Q
;
LOOK F ADMDT=0:0 S ADMDT=$O(^TMP($J,ADMDT)) Q:ADMDT="" F LADM=0:0 S LADM=$O(^TMP($J,ADMDT,LADM)) Q:LADM="" F DFN=0:0 S DFN=$O(^TMP($J,ADMDT,LADM,DFN)) Q:DFN="" D LOOK1
Q
;
DATA S Y=DT X ^DD("DD") S FDT(0)=Y,CNT=0
D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL ;for TaskMan,manual
S DTAR=^DVB(396.1,1,0),HD1=$P(DTAR,U,1)
U IO S NAME="" F J=0:0 S NAME=$O(^DVB(396,"B",NAME)) Q:NAME="" F XDA=0:0 S XDA=$O(^DVB(396,"B",NAME,XDA)) Q:XDA="" I $P(^DVB(396,XDA,0),U,7)="YES"&($P(^(0),U,13)="P") D CHK
D LOOK ;**Loop Recs to create 21-day certs
W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF
W !!!,"Notice to MAS personnel on "_FDT(0),! I '$D(^TMP($J)) W !!!,"There were no 21 day certificates to print today.",!! G KILL
W !!!,"There were "_CNT_" certificates processed on "_FDT(0),!!
;
KILL I $D(DVBAMAN)&($D(ZTQUEUED)) D KILL^%ZTLOAD
K DVBAMAN,DVBAON2,^TMP($J) G KILL^DVBAUTIL
;
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 W !!,"Patient record missing for DFN "_DFN,!! Q
S VAINDT=$P(^TMP($J,ADMDT,LADM,DFN),U,3),VA200="" D INP^VADPT K VA200 S WARD=$P(VAIN(4),U,2) 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 BED="Unknown" I $D(^DPT(DFN,.101)) S BED=$S($P(^(.101),U,1)]"":$P(^(.101),U,1),1:"Unknown")
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,?25," Bed: ",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:",!!!!!!!!!!!!!!!!!!!!
W "Physician signature: " F LINE=$X:1:80 W "_"
W !!!," Approved by: " F LINE=$X:1:65 W "_"
W !!?5,"ROC 119",!
S REQDIV=$P(^DVB(396,XDA,2),"^",9)
S DIE="^DVB(396,",DA=XDA,DR="6.5///C;6.8///"_DT_";6.9////"_"21-day certificate",NEWREQ=0 D ^DIE ;new request
I $P(^DVB(396,XDA,0),U,9)="" S DIE="^DVB(396,",DA=XDA,DR="4///YES;4.5///P;4.6///"_REQDIV_";4.7///"_DT,NEWREQ=1 D ^DIE ;notice of dischg request
I $P(^DVB(396,XDA,0),U,11)="" S DIE="^DVB(396,",DA=XDA,DR="5///YES;5.5///P;5.6///"_REQDIV_";5.7///"_DT,NEWREQ=1 D ^DIE ;hospital summary request
K REQDIV
S WWHO=$S($D(^DVB(396,XDA,2)):$P(^(2),U,8),1:"Unknown") I NEWREQ=1 S DIE="^DVB(396,",DA=XDA,DR="23///"_DT_";24///"_DT_";28///"_$E(WWHO,1,24)_"*" D ^DIE ;make new request to MAS
;NOTE: "*" system maintenance via this program
;S DIE="^DVB(396,",DR="6.82///N;6.86///"_DCHGDT_";6.87///"_WARD_";6.88///"_BED S DA=XDA D ^DIE S CNT=CNT+1 ; *203
;DVBA*2.7*203: Generate and automatically release 21-day certificate. A released status (#6.82=R) means the certificate is ready to be printed by the RO.
S DIE="^DVB(396,",DR="6.82///R;6.83////"_DT_";6.86///"_DCHGDT_";6.87///"_WARD_";6.88///"_BED S DA=XDA D ^DIE S CNT=CNT+1 ; *203 - Set #6.82 to R. Skip manual release process and make certs printable immediately
S DVBAON2=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBACERT 5054 printed Apr 09, 2024@20:50:20 Page 2
DVBACERT ;ALB/GTS-557/THM - 21 DAY CERT CHECKER ;1/23/91 11:17 AM
+1 ;;2.7;AMIE;**5,203**;Apr 10, 1995;Build 16
+2 ;
+3 KILL ^TMP($JOB)
SET DVBAMAN=""
+4 SET HD="MANUAL 21 DAY CERTIFICATE PROCESSING"
DO HOME^%ZIS
+5 IF '$DATA(DT)
SET X="T"
DO ^%DT
SET DT=Y
+6 WRITE @IOF,!?(IOM-$LENGTH(HD)\2),HD,!!,"This program should be run only if the Task Manager fails.",!!!
+7 SET %ZIS="AEQ"
DO ^%ZIS
KILL %ZIS
if POP
GOTO KILL
+8 IF $DATA(IO("Q"))
SET ZTIO=ION
SET ZTDESC="Manual 21-day Cert program"
SET ZTRTN="DATA^DVBACERT"
FOR I="HD","HD1","DVBAMAN"
SET ZTSAVE(I)=""
+9 IF $DATA(IO("Q"))
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Request queued.",!!
GOTO KILL
+10 GOTO DATA
+11 ;
CHK ; *203 - don't include seconds in admission date
SET ADMDT=$EXTRACT($PIECE(^DVB(396,XDA,0),U,4),1,12)
SET DFN=$PIECE(^(0),U,1)
SET STAT=$PIECE(^(1),U,12)
if STAT]""
QUIT
+1 ;K TEMP F I=0:0 S I=$O(^DGPM("APTT1",DFN,I)) Q:I="" F J=0:0 S J=$O(^DGPM("APTT1",DFN,I,J)) Q:J="" S ZJ=$S($D(^DGPM(J,0)):^(0),1:"") I ZJ]"" S TEMP(+$E(I,1,14),DFN)=J_U_+$E(I,1,14) ; *203
+2 ; *203 - Don't include seconds in date
KILL TEMP
FOR I=0:0
SET I=$ORDER(^DGPM("APTT1",DFN,I))
if I=""
QUIT
FOR J=0:0
SET J=$ORDER(^DGPM("APTT1",DFN,I,J))
if J=""
QUIT
SET ZJ=$SELECT($DATA(^DGPM(J,0)):^(0),1:"")
IF ZJ]""
SET TEMP(+$EXTRACT(I,1,12),DFN)=J_U_+$EXTRACT(I,1,12)
+3 SET DCHGDT=""
IF $DATA(TEMP(ADMDT,DFN))
DO CHK1
+4 ;**Dischrgd, stay >21 days
IF DCHGDT]""
DO LOS^DVBAUTIL
IF LOS'<21
SET ^TMP($JOB,ADMDT,MB,DFN)=XDA_U_DCHGDT_U_$PIECE(TEMP(ADMDT,DFN),U,2)
QUIT
+5 ;**Dchgd, stay <21
IF DCHGDT]""
DO LOS^DVBAUTIL
IF LOS<21
SET DR="6.5////C;6.8////"_DT_";6.9////"_"Not applicable"
SET DA=XDA
SET DIE="^DVB(396,"
DO ^DIE
KILL DA
QUIT
+6 QUIT
+7 ;
LOOK1 SET XDA=$PIECE(^TMP($JOB,ADMDT,LADM,DFN),U,1)
SET DCHGDT=$PIECE(^(DFN),U,2)
DO CREATE
+1 QUIT
+2 ;
CHK1 SET MB=$PIECE(TEMP(ADMDT,DFN),U,1)
SET DCHPTR=+$PIECE(^DGPM(MB,0),U,17)
+1 SET DCHGDT=$SELECT($DATA(^DGPM(DCHPTR,0)):$PIECE(^(0),U,1),1:"")
IF DCHGDT=""
SET DCHGDT=DT
DO LOS^DVBAUTIL
SET DCHGDT=""
IF LOS'<21
SET ^TMP($JOB,ADMDT,MB,DFN)=XDA_U_DT_U_$PIECE(TEMP(ADMDT,DFN),U,2)
QUIT
+2 ;null DCHGDT/use DT if vet still in hosp
+3 ;** If vet not discharged, DCHGDT="" on Quit
+4 QUIT
+5 ;
LOOK FOR ADMDT=0:0
SET ADMDT=$ORDER(^TMP($JOB,ADMDT))
if ADMDT=""
QUIT
FOR LADM=0:0
SET LADM=$ORDER(^TMP($JOB,ADMDT,LADM))
if LADM=""
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^TMP($JOB,ADMDT,LADM,DFN))
if DFN=""
QUIT
DO LOOK1
+1 QUIT
+2 ;
DATA SET Y=DT
XECUTE ^DD("DD")
SET FDT(0)=Y
SET CNT=0
+1 ;for TaskMan,manual
DO NOPARM^DVBAUTL2
if $DATA(DVBAQUIT)
GOTO KILL^DVBAUTIL
+2 SET DTAR=^DVB(396.1,1,0)
SET HD1=$PIECE(DTAR,U,1)
+3 USE IO
SET NAME=""
FOR J=0:0
SET NAME=$ORDER(^DVB(396,"B",NAME))
if NAME=""
QUIT
FOR XDA=0:0
SET XDA=$ORDER(^DVB(396,"B",NAME,XDA))
if XDA=""
QUIT
IF $PIECE(^DVB(396,XDA,0),U,7)="YES"&($PIECE(^(0),U,13)="P")
DO CHK
+4 ;**Loop Recs to create 21-day certs
DO LOOK
+5 if (IOST?1"C-".E)!($DATA(DVBAON2))
WRITE @IOF
+6 WRITE !!!,"Notice to MAS personnel on "_FDT(0),!
IF '$DATA(^TMP($JOB))
WRITE !!!,"There were no 21 day certificates to print today.",!!
GOTO KILL
+7 WRITE !!!,"There were "_CNT_" certificates processed on "_FDT(0),!!
+8 ;
KILL IF $DATA(DVBAMAN)&($DATA(ZTQUEUED))
DO KILL^%ZTLOAD
+1 KILL DVBAMAN,DVBAON2,^TMP($JOB)
GOTO KILL^DVBAUTIL
+2 ;
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
WRITE !!,"Patient record missing for DFN "_DFN,!!
QUIT
+3 SET VAINDT=$PIECE(^TMP($JOB,ADMDT,LADM,DFN),U,3)
SET VA200=""
DO INP^VADPT
KILL VA200
SET WARD=$PIECE(VAIN(4),U,2)
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")
+4 SET BED="Unknown"
IF $DATA(^DPT(DFN,.101))
SET BED=$SELECT($PIECE(^(.101),U,1)]"":$PIECE(^(.101),U,1),1:"Unknown")
+5 USE IO
+6 if (IOST?1"C-".E)!($DATA(DVBAON2))
WRITE @IOF
+7 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,?25," Bed: ",BED,!!!
+8 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:",!!!!!!!!!!!!!!!!!!!!
+9 WRITE "Physician signature: "
FOR LINE=$X:1:80
WRITE "_"
+10 WRITE !!!," Approved by: "
FOR LINE=$X:1:65
WRITE "_"
+11 WRITE !!?5,"ROC 119",!
+12 SET REQDIV=$PIECE(^DVB(396,XDA,2),"^",9)
+13 ;new request
SET DIE="^DVB(396,"
SET DA=XDA
SET DR="6.5///C;6.8///"_DT_";6.9////"_"21-day certificate"
SET NEWREQ=0
DO ^DIE
+14 ;notice of dischg request
IF $PIECE(^DVB(396,XDA,0),U,9)=""
SET DIE="^DVB(396,"
SET DA=XDA
SET DR="4///YES;4.5///P;4.6///"_REQDIV_";4.7///"_DT
SET NEWREQ=1
DO ^DIE
+15 ;hospital summary request
IF $PIECE(^DVB(396,XDA,0),U,11)=""
SET DIE="^DVB(396,"
SET DA=XDA
SET DR="5///YES;5.5///P;5.6///"_REQDIV_";5.7///"_DT
SET NEWREQ=1
DO ^DIE
+16 KILL REQDIV
+17 ;make new request to MAS
SET WWHO=$SELECT($DATA(^DVB(396,XDA,2)):$PIECE(^(2),U,8),1:"Unknown")
IF NEWREQ=1
SET DIE="^DVB(396,"
SET DA=XDA
SET DR="23///"_DT_";24///"_DT_";28///"_$EXTRACT(WWHO,1,24)_"*"
DO ^DIE
+18 ;NOTE: "*" system maintenance via this program
+19 ;S DIE="^DVB(396,",DR="6.82///N;6.86///"_DCHGDT_";6.87///"_WARD_";6.88///"_BED S DA=XDA D ^DIE S CNT=CNT+1 ; *203
+20 ;DVBA*2.7*203: Generate and automatically release 21-day certificate. A released status (#6.82=R) means the certificate is ready to be printed by the RO.
+21 ; *203 - Set #6.82 to R. Skip manual release process and make certs printable immediately
SET DIE="^DVB(396,"
SET DR="6.82///R;6.83////"_DT_";6.86///"_DCHGDT_";6.87///"_WARD_";6.88///"_BED
SET DA=XDA
DO ^DIE
SET CNT=CNT+1
+22 SET DVBAON2=""
+23 QUIT
