FHADR3.m

FHADR3 ; HISC/NCA - Facility Workload ;11/3/94  15:37

 ;;5.5;DIETETICS;;Jan 28, 2005

EN1 ; Enter/Edit Outpatients Visits

 D QR^FHADR1 G:'PRE KIL

 S OLD=$S($E(PRE,5)=1:$E(PRE,1,3)-1_"0400",1:$E(PRE,1,5)-1_"00")

 S (Z,ZZZ)=""

 K DIC,DIE W ! S DIE="^FH(117.3,",DA=PRE

 S DR="21;23;S:X'="""" ZZZ=X"

 L +^FH(117.3,PRE,0):0 I '$T W !?5,"Another user is editing the entry." G KIL

 D ^DIE K DR

 I ZZZ,$D(^FH(117.3,OLD,"CLIN",0)) D

 .I '$D(^FH(117.3,PRE,"CLIN",0)) D

 ..S ^FH(117.3,PRE,"CLIN",0)="^117.325^^",NDE=$G(^FH(117.3,PRE,"CLIN",0)),NDE=$P(NDE,"^",4)

 ..F LP=0:0 S LP=$O(^FH(117.3,OLD,"CLIN",LP)) Q:LP<1  S Z1=$G(^(LP,0)) D 

 ...I Z1'="",'$D(^FH(117.3,PRE,"CLIN",LP,0)) S ^(0)=$P(Z1,"^",1),^FH(117.3,PRE,"CLIN","B",$P(Z1,"^",1),LP)="",NDE=NDE+1,$P(^FH(117.3,PRE,"CLIN",0),"^",3,4)=LP_"^"_NDE Q

 ..Q

 .Q

 S DR="I 'ZZZ S Y="""";25"

 S DR(2,117.325)=".01:1"

 D ^DIE L -^FH(117.3,PRE,0) K DIE,DR

KIL G KILL^XUSCLEAN

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FHADR3   932     printed  Apr 09, 2024@20:52:23                                                                                                                                                                                                       Page 2

FHADR3    ; HISC/NCA - Facility Workload ;11/3/94  15:37

 +1       ;;5.5;DIETETICS;;Jan 28, 2005

EN1       ; Enter/Edit Outpatients Visits

 +1        DO QR^FHADR1

           if 'PRE

               GOTO KIL

 +2        SET OLD=$SELECT($EXTRACT(PRE,5)=1:$EXTRACT(PRE,1,3)-1_"0400",1:$EXTRACT(PRE,1,5)-1_"00")

 +3        SET (Z,ZZZ)=""

 +4        KILL DIC,DIE

           WRITE !

           SET DIE="^FH(117.3,"

           SET DA=PRE

 +5        SET DR="21;23;S:X'="""" ZZZ=X"

 +6        LOCK +^FH(117.3,PRE,0):0

           IF '$TEST

               WRITE !?5,"Another user is editing the entry."

               GOTO KIL

 +7        DO ^DIE

           KILL DR

 +8        IF ZZZ

               IF $DATA(^FH(117.3,OLD,"CLIN",0))

                   Begin DoDot:1

 +9                    IF '$DATA(^FH(117.3,PRE,"CLIN",0))

                           Begin DoDot:2

 +10                           SET ^FH(117.3,PRE,"CLIN",0)="^117.325^^"

                               SET NDE=$GET(^FH(117.3,PRE,"CLIN",0))

                               SET NDE=$PIECE(NDE,"^",4)

 +11                           FOR LP=0:0

                                   SET LP=$ORDER(^FH(117.3,OLD,"CLIN",LP))

                                   if LP<1

                                       QUIT 

                                   SET Z1=$GET(^(LP,0))

                                   Begin DoDot:3

 +12                                   IF Z1'=""

                                           IF '$DATA(^FH(117.3,PRE,"CLIN",LP,0))

                                               SET ^(0)=$PIECE(Z1,"^",1)

                                               SET ^FH(117.3,PRE,"CLIN","B",$PIECE(Z1,"^",1),LP)=""

                                               SET NDE=NDE+1

                                               SET $PIECE(^FH(117.3,PRE,"CLIN",0),"^",3,4)=LP_"^"_NDE

                                               QUIT 

                                   End DoDot:3

 +13                           QUIT 

                           End DoDot:2

 +14                   QUIT 

                   End DoDot:1

 +15       SET DR="I 'ZZZ S Y="""";25"

 +16       SET DR(2,117.325)=".01:1"

 +17       DO ^DIE

           LOCK -^FH(117.3,PRE,0)

           KILL DIE,DR

KIL        GOTO KILL^XUSCLEAN