- DVBACRMS ;ALB/GTS-557/THM - PRINT 21-DAY CERT FOR RO ;21 JUL 89
- ;;2.7;AMIE;**203**;Apr 10, 1995;Build 16
- ;
- D DUZ2^DVBAUTIL G:$D(DVBAQUIT) KILL
- I '$D(^DVB(396,"AC",DVBAD2,"R")) W !!,*7,"There are no new 21-DAY CERTIFICATES to print.",! H 2 Q
- I $D(DUZ)#2=0 W !!,*7,"Your USER NUMBER is missing. Call the site manager.",!! H 3 G KILL
- S HD="REGIONAL OFFICE 21-DAY CERTIFICATE PRINTING" D:'$G(DVBGUI) HOME^%ZIS D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL S DTAR=^DVB(396.1,1,0),HD1=$P(DTAR,U,1) ; *203 - Don't change value of IO if using GUI
- S OPER=$S($D(^VA(200,+DUZ,0)):$P(^(0),U,1),1:"Unknown")
- I '$D(DT) S X="T" D ^%DT S DT=Y
- S Y=DT X ^DD("DD") S FDT(0)=Y
- W @IOF,!?(IOM-$L(HD)\2),HD,!!!,"This program generates ORIGINAL Regional Office 21-day certificates.",!!
- W !! I '$G(DVBGUI) D ; *203 - Don't change value of IO if using GUI, don't use ^%ZTLOAD
- .S %ZIS="AEQ" D ^%ZIS K %ZIS G:POP KILL ; *203
- .I $D(IO("Q")) S ZTIO=ION,ZTDESC="Original RO 21-day Cert Printing",ZTRTN="DATA^DVBACRMS" F I="DVBAD2","HD","HD1","OPER","FDT(0)" S ZTSAVE(I)="" ; *203
- .I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued.",!! K ZTSK,ZTIO,ZTRTN,ZTDESC G KILL ; *203
- G DATA
- ;
- DATA U IO F XDA=0:0 S XDA=$O(^DVB(396,"AC",DVBAD2,"R",XDA)) Q:XDA="" S DFN=$P(^DVB(396,XDA,0),U,1) D CREATE
- ;
- KILL K DVBAON2 Q:$G(DVBGUI) D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBAUTIL ; *203 - If using GUI, don't use ^%ZTLOAD, don't kill ^TMP("DVBA",$J)
- ;
- CREATE ;CERTIFICATE CREATE
- ;Note: DCHGDT becomes a pseudo-discharge date, that is the date the
- ; report was run and he became eligible for a 21-day cert.
- 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 DIE="^DVB(396,",DA=XDA,DR="6.82///P;6.85///"_DT_";6.89///"_OPER D ^DIE
- S DVBAON2=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBACRMS 2808 printed Feb 18, 2025@23:07:24 Page 2
- DVBACRMS ;ALB/GTS-557/THM - PRINT 21-DAY CERT FOR RO ;21 JUL 89
- +1 ;;2.7;AMIE;**203**;Apr 10, 1995;Build 16
- +2 ;
- +3 DO DUZ2^DVBAUTIL
- if $DATA(DVBAQUIT)
- GOTO KILL
- +4 IF '$DATA(^DVB(396,"AC",DVBAD2,"R"))
- WRITE !!,*7,"There are no new 21-DAY CERTIFICATES to print.",!
- HANG 2
- QUIT
- +5 IF $DATA(DUZ)#2=0
- WRITE !!,*7,"Your USER NUMBER is missing. Call the site manager.",!!
- HANG 3
- GOTO KILL
- +6 ; *203 - Don't change value of IO if using GUI
- SET HD="REGIONAL OFFICE 21-DAY CERTIFICATE PRINTING"
- if '$GET(DVBGUI)
- DO HOME^%ZIS
- DO NOPARM^DVBAUTL2
- if $DATA(DVBAQUIT)
- GOTO KILL^DVBAUTIL
- SET DTAR=^DVB(396.1,1,0)
- SET HD1=$PIECE(DTAR,U,1)
- +7 SET OPER=$SELECT($DATA(^VA(200,+DUZ,0)):$PIECE(^(0),U,1),1:"Unknown")
- +8 IF '$DATA(DT)
- SET X="T"
- DO ^%DT
- SET DT=Y
- +9 SET Y=DT
- XECUTE ^DD("DD")
- SET FDT(0)=Y
- +10 WRITE @IOF,!?(IOM-$LENGTH(HD)\2),HD,!!!,"This program generates ORIGINAL Regional Office 21-day certificates.",!!
- +11 ; *203 - Don't change value of IO if using GUI, don't use ^%ZTLOAD
- WRITE !!
- IF '$GET(DVBGUI)
- Begin DoDot:1
- +12 ; *203
- SET %ZIS="AEQ"
- DO ^%ZIS
- KILL %ZIS
- if POP
- GOTO KILL
- +13 ; *203
- IF $DATA(IO("Q"))
- SET ZTIO=ION
- SET ZTDESC="Original RO 21-day Cert Printing"
- SET ZTRTN="DATA^DVBACRMS"
- FOR I="DVBAD2","HD","HD1","OPER","FDT(0)"
- SET ZTSAVE(I)=""
- +14 ; *203
- IF $DATA(IO("Q"))
- DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !!,"Request queued.",!!
- KILL ZTSK,ZTIO,ZTRTN,ZTDESC
- GOTO KILL
- End DoDot:1
- +15 GOTO DATA
- +16 ;
- DATA USE IO
- FOR XDA=0:0
- SET XDA=$ORDER(^DVB(396,"AC",DVBAD2,"R",XDA))
- if XDA=""
- QUIT
- SET DFN=$PIECE(^DVB(396,XDA,0),U,1)
- DO CREATE
- +1 ;
- KILL ; *203 - If using GUI, don't use ^%ZTLOAD, don't kill ^TMP("DVBA",$J)
- KILL DVBAON2
- if $GET(DVBGUI)
- QUIT
- if $DATA(ZTQUEUED)
- DO KILL^%ZTLOAD
- GOTO KILL^DVBAUTIL
- +1 ;
- CREATE ;CERTIFICATE CREATE
- +1 ;Note: DCHGDT becomes a pseudo-discharge date, that is the date the
- +2 ; report was run and he became eligible for a 21-day cert.
- +3 IF $DATA(^DVB(396,XDA,2))
- if $PIECE(^(2),U,10)="L"
- QUIT
- +4 IF '$DATA(^DPT(DFN,0))
- if (IOST?1"C-".E)!($DATA(DVBAON2))
- WRITE @IOF
- +5 IF '$DATA(^DPT(DFN,0))
- WRITE !!,"Patient record missing for DFN ",DFN,!!
- +6 IF '$DATA(^DPT(DFN,0))
- SET DVBAON2=""
- QUIT
- +7 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")
- +8 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)
- +9 USE IO
- if (IOST?1"C-".E)!($DATA(DVBAON2))
- WRITE @IOF
- +10 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,!!!
- +11 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:",!!!
- +12 KILL ^UTILITY($JOB,"W")
- +13 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
- +14 DO ^DIWW
- WRITE !!!,"A signed copy of this document is on file at "_HD1,!
- +15 WRITE !!?5,"R0C 119",!
- +16 SET DIE="^DVB(396,"
- SET DA=XDA
- SET DR="6.82///P;6.85///"_DT_";6.89///"_OPER
- DO ^DIE
- +17 SET DVBAON2=""
- +18 QUIT
