DGPTFFB.m

DGPTFFB ;ALB/JDS - FEE BASIS PTF ; 26 JUN 87

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

 ;

EN D LO^DGUTL F DGDUMB=0:0 K DGPTOUT D SEL Q:$D(DGPTOUT)

 K DIPGM,DISYS,DN,DGPTOUT,DGDUMB Q

 ;

SEL ; -- ask for pt

 W ! K DIC

 S DIC(0)="AEQMZ",DIC("A")="Enter Non-VA PTF Patient: ",DIC="^DPT("

 D ^DIC K DIC I Y'>0 S DGPTOUT="" G SELQ

 S (DA,DFN)=+Y D INFO

 ;

AD ; -- ask for adm date

 R !!,"Enter NEW Non-VA PTF Admission Date: ",X:DTIME G SELQ:(U[X)!('$T) S %DT="XETP" D ^%DT G AD:Y<2000000 S DGADM=+Y D CHK G AD:'Y

 ;

 ; -- create new PTF rec

 S Y=1 D RTY^DGPTUTL S Y=DGADM_"^1" D CREATE^DGPTFCR S PTF=+Y

 ;

 ; -- go to load edit

 S DGREL=$S($D(^XUSEC("DG PTFREL",DUZ)):1,1:0),DGADPR=9999999,DGPR=0,DGST=0,DGPTFE=1 K DGDFN

 D INCOME^DGPTUTL1,GETD^DGPTF

 ;

SELQ K DGADM,DGPTF,POP,D0,C,DN,PTF,DFN,DGREL,DA,DGADPR,DGDD,DGDFN,DIC,DIE,DIK,DR,I,L,X,Y,DGRTY,DGRTY0

 Q

 ;

INFO ; -- brief PTF rec profile for DFN pt

 ; -- is template compiled?

 S X="DGPTXB" X ^%ZOSF("TEST") K DXS G INFOQ:'$T

 S IOP="HOME" D ^%ZIS K IOP D PID^VADPT6

 W @IOF,?5,"****   PTF Record Profile for ",$E($P(Y(0),U),1,25),"  (",VA("PID"),")  ****"

 D HEAD^DGPTXB K DGPTX S DGPTCNT=0,DGPTMAX=$S($D(DGPTMAX):+DGPTMAX,1:15)

 ; -- sort in inverse date order

 F I=0:0 S I=$O(^DGPT("B",DFN,I)) Q:'I  I $D(^DGPT(I,0)) S DGPTX(9999999.999999-$P(^(0),"^",2),I)=""

 ; -- display data

 I $D(DGPTX) F DGPTX=0:0 S DGPTX=$O(DGPTX(DGPTX)) Q:'DGPTX  S DGPTCNT=DGPTCNT+1 Q:DGPTCNT>DGPTMAX  F PTF=0:0 S PTF=$O(DGPTX(DGPTX,PTF)) Q:'PTF  S D0=PTF K DXS D ^DGPTXB W !

 I DGPTCNT>DGPTMAX W !?5,"...only last ",DGPTMAX," records are displayed."

 I '$D(DGPTX) W !?5," No PTF records on file for patient."

INFOQ K DXS,DGPTCNT,DGPTX,VA,D0,PTF,DGPTMAX

 Q

 ;

CHK ; -- check if adm on date already exists

 K Y

 F I=0:0 S I=$O(^DGPT("B",DFN,I)) Q:'I  I $D(^DGPT(I,0)),$P(DGADM,".")=$P($P(^(0),U,2),".") S Y=$P(^(0),U,2) Q

 I '$D(Y) S Y=1 G CHKQ

 X ^DD("DD") W !!,*7,"PTF #",I," already exist for that admission date (",Y,").",!

 S DIR(0)="Y",DIR("A")="Do you still want to create a new PTF"

 S DIR("?",1)="Answer 'Yes' to add a new PTF record"

 S DIR("?",2)="       'NO'  to not add another PTF record"

 S DIR("?")=" "

 S DIR("B")="NO" D ^DIR K DIR

CHKQ Q

DGPTFFB   ;ALB/JDS - FEE BASIS PTF ; 26 JUN 87

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

 +2       ;

EN         DO LO^DGUTL

           FOR DGDUMB=0:0

               KILL DGPTOUT

               DO SEL

               IF $DATA(DGPTOUT)

                   QUIT 

 +1        KILL DIPGM,DISYS,DN,DGPTOUT,DGDUMB

           QUIT 

 +2       ;

SEL       ; -- ask for pt

 +1        WRITE !

           KILL DIC

 +2        SET DIC(0)="AEQMZ"

           SET DIC("A")="Enter Non-VA PTF Patient: "

           SET DIC="^DPT("

 +3        DO ^DIC

           KILL DIC

           IF Y'>0

               SET DGPTOUT=""

               GOTO SELQ

 +4        SET (DA,DFN)=+Y

           DO INFO

 +5       ;

AD        ; -- ask for adm date

 +1        READ !!,"Enter NEW Non-VA PTF Admission Date: ",X:DTIME

           IF (U[X)!('$TEST)

               GOTO SELQ

           SET %DT="XETP"

           DO ^%DT

           IF Y<2000000

               GOTO AD

           SET DGADM=+Y

           DO CHK

           IF 'Y

               GOTO AD

 +2       ;

 +3       ; -- create new PTF rec

 +4        SET Y=1

           DO RTY^DGPTUTL

           SET Y=DGADM_"^1"

           DO CREATE^DGPTFCR

           SET PTF=+Y

 +5       ;

 +6       ; -- go to load edit

 +7        SET DGREL=$SELECT($DATA(^XUSEC("DG PTFREL",DUZ)):1,1:0)

           SET DGADPR=9999999

           SET DGPR=0

           SET DGST=0

           SET DGPTFE=1

           KILL DGDFN

 +8        DO INCOME^DGPTUTL1

           DO GETD^DGPTF

 +9       ;

SELQ       KILL DGADM,DGPTF,POP,D0,C,DN,PTF,DFN,DGREL,DA,DGADPR,DGDD,DGDFN,DIC,DIE,DIK,DR,I,L,X,Y,DGRTY,DGRTY0

 +1        QUIT 

 +2       ;

INFO      ; -- brief PTF rec profile for DFN pt

 +1       ; -- is template compiled?

 +2        SET X="DGPTXB"

           XECUTE ^%ZOSF("TEST")

           KILL DXS

           IF '$TEST

               GOTO INFOQ

 +3        SET IOP="HOME"

           DO ^%ZIS

           KILL IOP

           DO PID^VADPT6

 +4        WRITE @IOF,?5,"****   PTF Record Profile for ",$EXTRACT($PIECE(Y(0),U),1,25),"  (",VA("PID"),")  ****"

 +5        DO HEAD^DGPTXB

           KILL DGPTX

           SET DGPTCNT=0

           SET DGPTMAX=$SELECT($DATA(DGPTMAX):+DGPTMAX,1:15)

 +6       ; -- sort in inverse date order

 +7        FOR I=0:0

               SET I=$ORDER(^DGPT("B",DFN,I))

               IF 'I

                   QUIT 

               IF $DATA(^DGPT(I,0))

                   SET DGPTX(9999999.999999-$PIECE(^(0),"^",2),I)=""

 +8       ; -- display data

 +9        IF $DATA(DGPTX)

               FOR DGPTX=0:0

                   SET DGPTX=$ORDER(DGPTX(DGPTX))

                   IF 'DGPTX

                       QUIT 

                   SET DGPTCNT=DGPTCNT+1

                   IF DGPTCNT>DGPTMAX

                       QUIT 

                   FOR PTF=0:0

                       SET PTF=$ORDER(DGPTX(DGPTX,PTF))

                       IF 'PTF

                           QUIT 

                       SET D0=PTF

                       KILL DXS

                       DO ^DGPTXB

                       WRITE !

 +10       IF DGPTCNT>DGPTMAX

               WRITE !?5,"...only last ",DGPTMAX," records are displayed."

 +11       IF '$DATA(DGPTX)

               WRITE !?5," No PTF records on file for patient."

INFOQ      KILL DXS,DGPTCNT,DGPTX,VA,D0,PTF,DGPTMAX

 +1        QUIT 

 +2       ;

CHK       ; -- check if adm on date already exists

 +1        KILL Y

 +2        FOR I=0:0

               SET I=$ORDER(^DGPT("B",DFN,I))

               IF 'I

                   QUIT 

               IF $DATA(^DGPT(I,0))

                   IF $PIECE(DGADM,".")=$PIECE($PIECE(^(0),U,2),".")

                       SET Y=$PIECE(^(0),U,2)

                       QUIT 

 +3        IF '$DATA(Y)

               SET Y=1

               GOTO CHKQ

 +4        XECUTE ^DD("DD")

           WRITE !!,*7,"PTF #",I," already exist for that admission date (",Y,").",!

 +5        SET DIR(0)="Y"

           SET DIR("A")="Do you still want to create a new PTF"

 +6        SET DIR("?",1)="Answer 'Yes' to add a new PTF record"

 +7        SET DIR("?",2)="       'NO'  to not add another PTF record"

 +8        SET DIR("?")=" "

 +9        SET DIR("B")="NO"

           DO ^DIR

           KILL DIR

CHKQ       QUIT