| [613] | 1 | FHXIN ; HISC/REL - Create FHPT File ;2/23/00 09:54
|
|---|
| 2 | ;;5.5;DIETETICS;;Jan 28, 2005
|
|---|
| 3 | S U="^" D DT^DICRW
|
|---|
| 4 | I '$D(^FH(119.9,1,0)) W !!,"Set up initial Site Parameter File" K DIC,DD,DO D SITE^FH S DIC="^FH(119.9,",DIC(0)="L",DLAYGO=119.9,X=SITE(1),DINUM=1 D FILE^DICN K DIC,DLAYGO,DINUM
|
|---|
| 5 | I $P(^FH(115.6,0),"^",3)<50 S $P(^(0),"^",3)=50
|
|---|
| 6 | R6 K ADM,FHDFN,DFN,DIC,DINUM,DMAX,KK,KKK,WRD,X,Y Q
|
|---|
| 7 | EN1 S WRD=""
|
|---|
| 8 | F1 S WRD=$O(^DPT("CN",WRD)) I WRD="" W !!," ... done." K ADM,D,FHDFN,DFN,I,WRD,X,Y Q
|
|---|
| 9 | S DFN=""
|
|---|
| 10 | F2 S DFN=$O(^DPT("CN",WRD,DFN)) G:DFN="" F1 S ADM=^(DFN) G:ADM<1 ERR
|
|---|
| 11 | G:'$D(^DGPM(ADM,0)) ERR S X=$P(^(0),"^",1)
|
|---|
| 12 | S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
|
|---|
| 13 | I '$D(^FHPT(FHDFN)) S ^FHPT(FHDFN,0)="P"_DFN,$P(^FHPT(FHDFN,0),U,3)=DFN,$P(^FHPT(0),"^",3)=FHDFN,$P(^FHPT(0),"^",4)=$P(^(0),"^",4)+1
|
|---|
| 14 | I '$D(^FHPT(FHDFN,"A",0)) S ^FHPT(FHDFN,"A",0)="^115.01^^"
|
|---|
| 15 | I $D(^FHPT(FHDFN,"A",ADM)) S $P(^(ADM,0),"^",1)=X G F2
|
|---|
| 16 | S $P(^FHPT(FHDFN,"A",0),"^",3)=ADM,$P(^(0),"^",4)=$P(^(0),"^",4)+1
|
|---|
| 17 | S ^FHPT(FHDFN,"A",ADM,0)=X_"^^^^^^^^^^^" D WRD^FHWADM G F2
|
|---|
| 18 | ERR W !!,"Error for FHDFN ",FHDFN," - Admission not Found" G F2
|
|---|
