- FHXIN ; HISC/REL - Create FHPT File ;2/23/00 09:54
- ;;5.5;DIETETICS;;Jan 28, 2005
- S U="^" D DT^DICRW
- 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
- I $P(^FH(115.6,0),"^",3)<50 S $P(^(0),"^",3)=50
- R6 K ADM,FHDFN,DFN,DIC,DINUM,DMAX,KK,KKK,WRD,X,Y Q
- EN1 S WRD=""
- F1 S WRD=$O(^DPT("CN",WRD)) I WRD="" W !!," ... done." K ADM,D,FHDFN,DFN,I,WRD,X,Y Q
- S DFN=""
- F2 S DFN=$O(^DPT("CN",WRD,DFN)) G:DFN="" F1 S ADM=^(DFN) G:ADM<1 ERR
- G:'$D(^DGPM(ADM,0)) ERR S X=$P(^(0),"^",1)
- S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
- 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
- I '$D(^FHPT(FHDFN,"A",0)) S ^FHPT(FHDFN,"A",0)="^115.01^^"
- I $D(^FHPT(FHDFN,"A",ADM)) S $P(^(ADM,0),"^",1)=X G F2
- S $P(^FHPT(FHDFN,"A",0),"^",3)=ADM,$P(^(0),"^",4)=$P(^(0),"^",4)+1
- S ^FHPT(FHDFN,"A",ADM,0)=X_"^^^^^^^^^^^" D WRD^FHWADM G F2
- ERR W !!,"Error for FHDFN ",FHDFN," - Admission not Found" G F2
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHXIN 1111 printed Feb 18, 2025@23:22:06 Page 2
- FHXIN ; HISC/REL - Create FHPT File ;2/23/00 09:54
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 SET U="^"
- DO DT^DICRW
- +3 IF '$DATA(^FH(119.9,1,0))
- WRITE !!,"Set up initial Site Parameter File"
- KILL DIC,DD,DO
- DO SITE^FH
- SET DIC="^FH(119.9,"
- SET DIC(0)="L"
- SET DLAYGO=119.9
- SET X=SITE(1)
- SET DINUM=1
- DO FILE^DICN
- KILL DIC,DLAYGO,DINUM
- +4 IF $PIECE(^FH(115.6,0),"^",3)<50
- SET $PIECE(^(0),"^",3)=50
- R6 KILL ADM,FHDFN,DFN,DIC,DINUM,DMAX,KK,KKK,WRD,X,Y
- QUIT
- EN1 SET WRD=""
- F1 SET WRD=$ORDER(^DPT("CN",WRD))
- IF WRD=""
- WRITE !!," ... done."
- KILL ADM,D,FHDFN,DFN,I,WRD,X,Y
- QUIT
- +1 SET DFN=""
- F2 SET DFN=$ORDER(^DPT("CN",WRD,DFN))
- if DFN=""
- GOTO F1
- SET ADM=^(DFN)
- if ADM<1
- GOTO ERR
- +1 if '$DATA(^DGPM(ADM,0))
- GOTO ERR
- SET X=$PIECE(^(0),"^",1)
- +2 SET FHZ115="P"_DFN
- DO CHECK^FHOMDPA
- IF FHDFN=""
- QUIT
- +3 IF '$DATA(^FHPT(FHDFN))
- SET ^FHPT(FHDFN,0)="P"_DFN
- SET $PIECE(^FHPT(FHDFN,0),U,3)=DFN
- SET $PIECE(^FHPT(0),"^",3)=FHDFN
- SET $PIECE(^FHPT(0),"^",4)=$PIECE(^(0),"^",4)+1
- +4 IF '$DATA(^FHPT(FHDFN,"A",0))
- SET ^FHPT(FHDFN,"A",0)="^115.01^^"
- +5 IF $DATA(^FHPT(FHDFN,"A",ADM))
- SET $PIECE(^(ADM,0),"^",1)=X
- GOTO F2
- +6 SET $PIECE(^FHPT(FHDFN,"A",0),"^",3)=ADM
- SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1
- +7 SET ^FHPT(FHDFN,"A",ADM,0)=X_"^^^^^^^^^^^"
- DO WRD^FHWADM
- GOTO F2
- ERR WRITE !!,"Error for FHDFN ",FHDFN," - Admission not Found"
- GOTO F2
