- 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 Jan 18, 2025@02:42:10 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