DGPTFFB ;ALB/JDS - FEE BASIS PTF ;Aug 19, 2020@11:25
;;5.3;Registration;**932,1020**;Aug 13, 1993;Build 11
;
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 ; -- clean-up
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFFB 2274 printed Sep 23, 2025@20:28:04 Page 2
DGPTFFB ;ALB/JDS - FEE BASIS PTF ;Aug 19, 2020@11:25
+1 ;;5.3;Registration;**932,1020**;Aug 13, 1993;Build 11
+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 ; -- clean-up
+1 KILL DGADM,DGPTF,POP,D0,C,DN,PTF,DFN,DGREL,DA,DGADPR,DGDD,DGDFN,DIC,DIE,DIK,DR,I,L,X,Y,DGRTY,DGRTY0
+2 QUIT
+3 ;
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
