source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFFB.m@ 1141

Last change on this file since 1141 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.1 KB
RevLine 
[613]1DGPTFFB ;ALB/JDS - FEE BASIS PTF ; 26 JUN 87
2 ;;5.3;Registration;;Aug 13, 1993
3 ;
4EN D LO^DGUTL F DGDUMB=0:0 K DGPTOUT D SEL Q:$D(DGPTOUT)
5 K DIPGM,DISYS,DN,DGPTOUT,DGDUMB Q
6 ;
7SEL ; -- 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 ;
13AD ; -- 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 ;
23SELQ 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 ;
26INFO ; -- 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."
38INFOQ K DXS,DGPTCNT,DGPTX,VA,D0,PTF,DGPTMAX
39 Q
40 ;
41CHK ; -- 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
51CHKQ Q
Note: See TracBrowser for help on using the repository browser.