DVBACRRP.m

DVBACRRP ;ALB/GTS-557/THM-REPRINT 21-DAY CERT FOR MAS ;21 JUL 89

 ;;2.7;AMIE;;Apr 10, 1995

 D INIT

 I 'CONT G KIL

 S DVBSEL=$$SELECT^DVBAUTL5("Original Processing Date","21 Day Certificate")

 I DVBSEL="D" S SDATE=$$DATE() G:SDATE<0 KIL

 I DVBSEL="N" S XDA=$$PAT^DVBAUTL5("MAS") G:XDA<1 KIL

 I DVBSEL=0 G KIL

 D DEVICE

 I 'CONT G KIL

 D DATA

 ;

KIL D KILL

 Q

 ;

DATA ;

 I DVBSEL="D" DO

 .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,14)=SDATE S DFN=$P(^(0),U,1) D CREATE

 .Q

 I DVBSEL="N" DO

 .S DFN=$P(^DVB(396,XDA,0),U,1)

 .D CREATE

 .Q

 I NODTA=0 DO

 .S VAR(1,0)="0,0,0,2:2,0^No data found to reprint"

 .D WR^DVBAUTL4("VAR")

 .K VAR

 .Q

 Q

 ;

KILL K %DT(0),SDATE,DVBAON2,DVBSEL,VAR,CONT

 I $D(ZTQUEUED) D KILL^%ZTLOAD

 D KILL^DVBAUTIL

 Q

 ;

CREATE ;CERTIFICATE CREATE

 Q:'$D(^DVB(396,XDA,4))

 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:",!!!!!!!!!!!!!!!!!!!!

 W "Physician signature: " F LINE=$X:1:80 W "_"

 W !!!,"        Approved by: " F LINE=$X:1:65 W "_"

 W !!?5,"R0C  119",!

 S NODTA=1

 S DVBAON2=""

 Q

 ;

INIT ;

 K ^TMP($J)

 S CONT=1,NODTA=0,HD="21-DAY CERTIFICATE REPRINTING"

 D HOME^%ZIS

 D NOPARM^DVBAUTL2

 I $D(DVBAQUIT) S CONT=0 Q

 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

 S VAR(1,0)="0,0,(IOM-$L(HD)\2),1:3,1:0^"_HD

 D WR^DVBAUTL4("VAR")

 K VAR

 Q

 ;

DATE() ;THis function returns a date of the original request from the user.

 S %DT(0)=-DT

 S %DT("A")="Enter ORIGINAL PROCESSING DATE: ",%DT="AEQ"

 D ^%DT

 K %DT

 Q Y

 ;

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^DVBACRRP"

 .F I="XDA","DVBSEL","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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DVBACRRP   2897     printed  Feb 18, 2025@23:07:25                                                                                                                                                                                                    Page 2

DVBACRRP  ;ALB/GTS-557/THM-REPRINT 21-DAY CERT FOR MAS ;21 JUL 89

 +1       ;;2.7;AMIE;;Apr 10, 1995

 +2        DO INIT

 +3        IF 'CONT

               GOTO KIL

 +4        SET DVBSEL=$$SELECT^DVBAUTL5("Original Processing Date","21 Day Certificate")

 +5        IF DVBSEL="D"

               SET SDATE=$$DATE()

               if SDATE<0

                   GOTO KIL

 +6        IF DVBSEL="N"

               SET XDA=$$PAT^DVBAUTL5("MAS")

               if XDA<1

                   GOTO KIL

 +7        IF DVBSEL=0

               GOTO KIL

 +8        DO DEVICE

 +9        IF 'CONT

               GOTO KIL

 +10       DO DATA

 +11      ;

KIL        DO KILL

 +1        QUIT 

 +2       ;

DATA      ;

 +1        IF DVBSEL="D"

               Begin DoDot:1

 +2                USE IO

 +3                SET NAME=""

 +4                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,14)=SDATE

                               SET DFN=$PIECE(^(0),U,1)

                               DO CREATE

 +5                QUIT 

               End DoDot:1

 +6        IF DVBSEL="N"

               Begin DoDot:1

 +7                SET DFN=$PIECE(^DVB(396,XDA,0),U,1)

 +8                DO CREATE

 +9                QUIT 

               End DoDot:1

 +10       IF NODTA=0

               Begin DoDot:1

 +11               SET VAR(1,0)="0,0,0,2:2,0^No data found to reprint"

 +12               DO WR^DVBAUTL4("VAR")

 +13               KILL VAR

 +14               QUIT 

               End DoDot:1

 +15       QUIT 

 +16      ;

KILL       KILL %DT(0),SDATE,DVBAON2,DVBSEL,VAR,CONT

 +1        IF $DATA(ZTQUEUED)

               DO KILL^%ZTLOAD

 +2        DO KILL^DVBAUTIL

 +3        QUIT 

 +4       ;

CREATE    ;CERTIFICATE CREATE

 +1        if '$DATA(^DVB(396,XDA,4))

               QUIT 

 +2        IF $DATA(^DVB(396,XDA,2))

               if $PIECE(^(2),U,10)="L"

                   QUIT 

 +3        IF '$DATA(^DPT(DFN,0))

               if (IOST?1"C-".E)!($DATA(DVBAON2))

                   WRITE @IOF

 +4        IF '$DATA(^DPT(DFN,0))

               WRITE !!,"Patient record missing for DFN ",DFN,!!

 +5        IF '$DATA(^DPT(DFN,0))

               SET DVBAON2=""

               QUIT 

 +6        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")

 +7        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)

 +8        USE IO

           if (IOST?1"C-".E)!($DATA(DVBAON2))

               WRITE @IOF

 +9        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,!!!

 +10       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:",!!!!!!!!!!!!!!!!!!!!

 +11       WRITE "Physician signature: "

           FOR LINE=$X:1:80

               WRITE "_"

 +12       WRITE !!!,"        Approved by: "

           FOR LINE=$X:1:65

               WRITE "_"

 +13       WRITE !!?5,"R0C  119",!

 +14       SET NODTA=1

 +15       SET DVBAON2=""

 +16       QUIT 

 +17      ;

INIT      ;

 +1        KILL ^TMP($JOB)

 +2        SET CONT=1

           SET NODTA=0

           SET HD="21-DAY CERTIFICATE REPRINTING"

 +3        DO HOME^%ZIS

 +4        DO NOPARM^DVBAUTL2

 +5        IF $DATA(DVBAQUIT)

               SET CONT=0

               QUIT 

 +6        SET HD1=$$SITE^DVBCUTL4()

 +7        IF '$DATA(DT)

               SET X="T"

               DO ^%DT

               SET DT=Y

 +8        SET Y=DT

           XECUTE ^DD("DD")

           SET FDT(0)=Y

 +9        SET VAR(1,0)="0,0,(IOM-$L(HD)\2),1:3,1:0^"_HD

 +10       DO WR^DVBAUTL4("VAR")

 +11       KILL VAR

 +12       QUIT 

 +13      ;

DATE()    ;THis function returns a date of the original request from the user.

 +1        SET %DT(0)=-DT

 +2        SET %DT("A")="Enter ORIGINAL PROCESSING DATE: "

           SET %DT="AEQ"

 +3        DO ^%DT

 +4        KILL %DT

 +5        QUIT Y

 +6       ;

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

           KILL %ZIS

 +6        IF POP

               SET CONT=0

               QUIT 

 +7        IF $DATA(IO("Q"))

               Begin DoDot:1

 +8                SET CONT=0

 +9                SET ZTIO=ION

                   SET ZTDESC="21-day Cert reprint"

                   SET ZTRTN="DATA^DVBACRRP"

 +10               FOR I="XDA","DVBSEL","FDT(0)","HD","HD1","SDATE","NODTA"

                       SET ZTSAVE(I)=""

 +11               DO ^%ZTLOAD

 +12               DO ^%ZISC

 +13               IF $DATA(ZTSK)

                       Begin DoDot:2

 +14                       SET VAR(1,0)="0,0,0,2:2,0^Request queued."

 +15                       DO WR^DVBAUTL4("VAR")

 +16                       KILL VAR

 +17                       QUIT 

                       End DoDot:2

 +18               QUIT 

               End DoDot:1

 +19       QUIT