DG3PR.m

DG3PR ;ALB/JDS - THIRD PARTY REIMBURSMENT ;01 JAN 1987

 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

EN W ! R "Sort by Discharge or Admission: D// ",X:DTIME S Z="^DISCHARGE^ADMISSION" Q:X["^"!'$T  I X="" S X="D" W X

 D IN^DGHELP I %<0 W !!,"CHOOSE FROM",!?4,"A - ADMISSION",!?4,"D - DISCHARGE",!?4,"^ - To QUIT",! G EN

 S DGBY=$S(X="D":"ATT3",1:"ATT1")

DAT S %DT(0)="-DT",%DT="AEPX",%DT("A")="START DATE: " D ^%DT G Q:X["^",DAT:Y<0 S DGFR=Y-.1

 S %DT("A")="  END DATE: ",%DT(0)=DGFR+.1,%DT="AEPX" D ^%DT G Q:X["^",DAT:Y<0 S DGTO=Y_.9

 S DGVAR="DGBY^DGFR^DGTO",DGPGM="SORT^DG3PR1" D ZIS^DGUTQ I 'POP D SORT^DG3PR1

Q K %,%DT,C,DFN,DGAD,DGBY,DGCA,DGDC,DGFL,DGFR,DGI,DGJ,DGLOL,DGNOW,DGPGM,DGPMIFN,DGPR,DGPTF,DGTIME,DGTO,DGTR,DGVAR,DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,J,K,L,M,POP,X,X1,X2,Y,Z,^UTILITY("DG",$J) D CLOSE^DGUTQ,KVAR^VADPT Q

DG3PR     ;ALB/JDS - THIRD PARTY REIMBURSMENT ;01 JAN 1987

 +1       ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

EN         WRITE !

           READ "Sort by Discharge or Admission: D// ",X:DTIME

           SET Z="^DISCHARGE^ADMISSION"

           IF X["^"!'$TEST

               QUIT 

           IF X=""

               SET X="D"

               WRITE X

 +1        DO IN^DGHELP

           IF %<0

               WRITE !!,"CHOOSE FROM",!?4,"A - ADMISSION",!?4,"D - DISCHARGE",!?4,"^ - To QUIT",!

               GOTO EN

 +2        SET DGBY=$SELECT(X="D":"ATT3",1:"ATT1")

DAT        SET %DT(0)="-DT"

           SET %DT="AEPX"

           SET %DT("A")="START DATE: "

           DO ^%DT

           IF X["^"

               GOTO Q

           IF Y<0

               GOTO DAT

           SET DGFR=Y-.1

 +1        SET %DT("A")="  END DATE: "

           SET %DT(0)=DGFR+.1

           SET %DT="AEPX"

           DO ^%DT

           IF X["^"

               GOTO Q

           IF Y<0

               GOTO DAT

           SET DGTO=Y_.9

 +2        SET DGVAR="DGBY^DGFR^DGTO"

           SET DGPGM="SORT^DG3PR1"

           DO ZIS^DGUTQ

           IF 'POP

               DO SORT^DG3PR1

Q          KILL %,%DT,C,DFN,DGAD,DGBY,DGCA,DGDC,DGFL,DGFR,DGI,DGJ,DGLOL,DGNOW,DGPGM,DGPMIFN,DGPR,DGPTF,DGTIME,DGTO,DGTR,DGVAR,DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,J,K,L,M,POP,X,X1,X2,Y,Z,^UTILITY("DG",$JOB)

           DO CLOSE^DGUTQ

           DO KVAR^VADPT

           QUIT