- FHASE3 ; HISC/REL - Encounter Utilities ;5/7/92 08:46
- ;;5.5;DIETETICS;;Jan 28, 2005
- FIL ; File encounter - DTE date/time S1 enc. ident S2 I/F S3 comment
- S S1=$O(^FH(115.6,"AX",S1,"")) Q:S1<1
- K DIC,DD,DO S DIC="^FHEN(",DIC(0)="L",DLAYGO=115.7
- F1 L +^FHEN(0) S DA=$P(^FHEN(0),"^",3)+1 I $D(^FHEN(DA)) S $P(^FHEN(0),"^",3)=DA L -^FHEN(0) G F1
- ;
- S (X,FHDA,DINUM)=DA D FILE^DICN L -^FHEN(0) S ASE=+Y K DIC,DLAYGO,DINUM
- S DTE=+DTE,S4=$S(S2="I":3,1:4),S4=$S($D(^FH(115.6,S1,0)):$P(^(0),"^",S4),1:0)
- S S5=$G(^DPT(DFN,.1)) S:S5'="" S5=$O(^DIC(42,"B",S5,0)) S S5=$G(^DIC(42,+S5,44))
- S ^FHEN(ASE,0)=ASE_"^"_DTE_"^"_DUZ_"^"_S1_"^^^"_S2_"^"_S4_"^I^1^^^"_DUZ_"^"_NOW
- S ^FHEN(ASE,"P",0)="^115.701P^"_DFN_"^1"
- S ^FHEN(ASE,"P",DFN,0)=DFN_"^"_S5_"^^"_S3
- S ^FHEN(ASE,"P","B",DFN,DFN)="",^FHEN("AP",DFN,DTE,ASE)="",^FHEN("AT",DTE,ASE)=""
- ;
- ; IF MULTIDIVISIONAL SITE STORE COMMUNICATIONS OFFICE CODE
- I $P($G(^FH(119.9,1,0)),U,20)'="N" D
- .S DA=FHDA,DIE="^FHEN(",DR="11////^S X=FHCOMM"
- .D ^DIE
- ;
- K ASE,DTE,S1,S2,S3,S4,S5 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHASE3 1046 printed Feb 18, 2025@23:13:09 Page 2
- FHASE3 ; HISC/REL - Encounter Utilities ;5/7/92 08:46
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- FIL ; File encounter - DTE date/time S1 enc. ident S2 I/F S3 comment
- +1 SET S1=$ORDER(^FH(115.6,"AX",S1,""))
- if S1<1
- QUIT
- +2 KILL DIC,DD,DO
- SET DIC="^FHEN("
- SET DIC(0)="L"
- SET DLAYGO=115.7
- F1 LOCK +^FHEN(0)
- SET DA=$PIECE(^FHEN(0),"^",3)+1
- IF $DATA(^FHEN(DA))
- SET $PIECE(^FHEN(0),"^",3)=DA
- LOCK -^FHEN(0)
- GOTO F1
- +1 ;
- +2 SET (X,FHDA,DINUM)=DA
- DO FILE^DICN
- LOCK -^FHEN(0)
- SET ASE=+Y
- KILL DIC,DLAYGO,DINUM
- +3 SET DTE=+DTE
- SET S4=$SELECT(S2="I":3,1:4)
- SET S4=$SELECT($DATA(^FH(115.6,S1,0)):$PIECE(^(0),"^",S4),1:0)
- +4 SET S5=$GET(^DPT(DFN,.1))
- if S5'=""
- SET S5=$ORDER(^DIC(42,"B",S5,0))
- SET S5=$GET(^DIC(42,+S5,44))
- +5 SET ^FHEN(ASE,0)=ASE_"^"_DTE_"^"_DUZ_"^"_S1_"^^^"_S2_"^"_S4_"^I^1^^^"_DUZ_"^"_NOW
- +6 SET ^FHEN(ASE,"P",0)="^115.701P^"_DFN_"^1"
- +7 SET ^FHEN(ASE,"P",DFN,0)=DFN_"^"_S5_"^^"_S3
- +8 SET ^FHEN(ASE,"P","B",DFN,DFN)=""
- SET ^FHEN("AP",DFN,DTE,ASE)=""
- SET ^FHEN("AT",DTE,ASE)=""
- +9 ;
- +10 ; IF MULTIDIVISIONAL SITE STORE COMMUNICATIONS OFFICE CODE
- +11 IF $PIECE($GET(^FH(119.9,1,0)),U,20)'="N"
- Begin DoDot:1
- +12 SET DA=FHDA
- SET DIE="^FHEN("
- SET DR="11////^S X=FHCOMM"
- +13 DO ^DIE
- End DoDot:1
- +14 ;
- +15 KILL ASE,DTE,S1,S2,S3,S4,S5
- QUIT
