| 1 | DGPTFFB ;ALB/JDS - FEE BASIS PTF ; 26 JUN 87
|
|---|
| 2 | ;;5.3;Registration;;Aug 13, 1993
|
|---|
| 3 | ;
|
|---|
| 4 | EN D LO^DGUTL F DGDUMB=0:0 K DGPTOUT D SEL Q:$D(DGPTOUT)
|
|---|
| 5 | K DIPGM,DISYS,DN,DGPTOUT,DGDUMB Q
|
|---|
| 6 | ;
|
|---|
| 7 | SEL ; -- ask for pt
|
|---|
| 8 | W ! K DIC
|
|---|
| 9 | S DIC(0)="AEQMZ",DIC("A")="Enter Non-VA PTF Patient: ",DIC="^DPT("
|
|---|
| 10 | D ^DIC K DIC I Y'>0 S DGPTOUT="" G SELQ
|
|---|
| 11 | S (DA,DFN)=+Y D INFO
|
|---|
| 12 | ;
|
|---|
| 13 | AD ; -- ask for adm date
|
|---|
| 14 | 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
|
|---|
| 15 | ;
|
|---|
| 16 | ; -- create new PTF rec
|
|---|
| 17 | S Y=1 D RTY^DGPTUTL S Y=DGADM_"^1" D CREATE^DGPTFCR S PTF=+Y
|
|---|
| 18 | ;
|
|---|
| 19 | ; -- go to load edit
|
|---|
| 20 | S DGREL=$S($D(^XUSEC("DG PTFREL",DUZ)):1,1:0),DGADPR=9999999,DGPR=0,DGST=0,DGPTFE=1 K DGDFN
|
|---|
| 21 | D INCOME^DGPTUTL1,GETD^DGPTF
|
|---|
| 22 | ;
|
|---|
| 23 | 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
|
|---|
| 24 | Q
|
|---|
| 25 | ;
|
|---|
| 26 | INFO ; -- brief PTF rec profile for DFN pt
|
|---|
| 27 | ; -- is template compiled?
|
|---|
| 28 | S X="DGPTXB" X ^%ZOSF("TEST") K DXS G INFOQ:'$T
|
|---|
| 29 | S IOP="HOME" D ^%ZIS K IOP D PID^VADPT6
|
|---|
| 30 | W @IOF,?5,"**** PTF Record Profile for ",$E($P(Y(0),U),1,25)," (",VA("PID"),") ****"
|
|---|
| 31 | D HEAD^DGPTXB K DGPTX S DGPTCNT=0,DGPTMAX=$S($D(DGPTMAX):+DGPTMAX,1:15)
|
|---|
| 32 | ; -- sort in inverse date order
|
|---|
| 33 | 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)=""
|
|---|
| 34 | ; -- display data
|
|---|
| 35 | 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 !
|
|---|
| 36 | I DGPTCNT>DGPTMAX W !?5,"...only last ",DGPTMAX," records are displayed."
|
|---|
| 37 | I '$D(DGPTX) W !?5," No PTF records on file for patient."
|
|---|
| 38 | INFOQ K DXS,DGPTCNT,DGPTX,VA,D0,PTF,DGPTMAX
|
|---|
| 39 | Q
|
|---|
| 40 | ;
|
|---|
| 41 | CHK ; -- check if adm on date already exists
|
|---|
| 42 | K Y
|
|---|
| 43 | 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
|
|---|
| 44 | I '$D(Y) S Y=1 G CHKQ
|
|---|
| 45 | X ^DD("DD") W !!,*7,"PTF #",I," already exist for that admission date (",Y,").",!
|
|---|
| 46 | S DIR(0)="Y",DIR("A")="Do you still want to create a new PTF"
|
|---|
| 47 | S DIR("?",1)="Answer 'Yes' to add a new PTF record"
|
|---|
| 48 | S DIR("?",2)=" 'NO' to not add another PTF record"
|
|---|
| 49 | S DIR("?")=" "
|
|---|
| 50 | S DIR("B")="NO" D ^DIR K DIR
|
|---|
| 51 | CHKQ Q
|
|---|
