- 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
