FHOMSA1.m

FHOMSA1 ;Hines OIFO/RTK SPECIAL MEALS AUTHORIZE MEAL  ;4/11/03  12:55

 ;;5.5;DIETETICS;**2**;Jan 28, 2005

 ;

 I '$D(^XUSEC("FHAUTH",DUZ)) W !!!,"To access this option you most hold the 'FHAUTH' key!",!! H 3 Q

 S STDT=DT,FHS="P" D LIST^FHOMSS1 W !

 I NUM=0 W !,"NO PENDING SPECIAL MEALS TO AUTHORIZE" Q

 K DIR S DIR("A")="Select Which Meal(s)?",DIR(0)="LO^1:"_NUM D ^DIR

 Q:$D(DIRUT)  S FHCLST=Y

 W ! K DIR S DIR("A")="Authorize or Deny? "

 S DIR(0)="SAO^A:AUTHORIZE;D:DENY",DIR("B")="A" D ^DIR

 Q:$D(DIRUT)  S FHSTAT=Y

 I FHSTAT="D" W ! K DIR S DIR("A")="Comment: ",DIR(0)="FA^1:80" D ^DIR S FHCOMM=Y

 I FHCOMM="^" W !!?3,"Changes NOT saved!",! H 2 Q

 W ! K DIR S DIR("A")="Are you sure? ",DIR(0)="YA",DIR("B")="Y" D ^DIR

 Q:$D(DIRUT)  I Y=0 D END Q

 D SIG^XUSESIG I X1="" W !!?5,"<< Incorrect Electronic Signature!! >>" Q

 F A=1:1:NUM S FHC=$P(FHCLST,",",A) Q:FHC=""  S FHCDT=FHLIST(FHC) D UPD,UPD100

 W "  ... done" Q

 Q

UPD ;Update the status,authorizor,date/time of special meal request

 D NOW^%DTC S FHTODAY=$E(%,1,12)

 S DA=$P(FHCDT,U,2),FHDA=DA,DA(1)=$P(FHCDT,U,1),FHDFN=DA(1)

 S DIE="^FHPT("_DA(1)_",""SM"","

 S DR="1////^S X=FHSTAT;5////^S X=DUZ;6////^S X=FHTODAY;7////^S X=FHCOMM"

 D ^DIE

 D ALERT

 S FHZN=$G(^FHPT(FHDFN,"SM",FHDA,0))

 S FHACT="O",FHOPTY="S",FHOPDT=$P(FHTODAY,".",1) D SETSM^FHOMRO2

 Q

ALERT ;Send alert back to requestor

 K XQA S (FHAUDA,FHDFN)=$P(FHCDT,U,1),FHAUSMDT=$P(FHCDT,U,2)

 S FHREQ=$P($G(^FHPT(FHAUDA,"SM",FHAUSMDT,0)),U,5) I FHREQ="" Q

 S FHAUSTT=$S(FHSTAT="A":"AUTHORIZED",1:"DENIED")

 S FHAUNAM=$P($G(^VA(200,DUZ,0)),U,1)

 D PATNAME^FHOMUTL

 S XQA(FHREQ)=""

 S XQAMSG=$E(FHPTNM,1,9)_" ("_$E(FHPTNM,1,1)_$P(FHSSN,"-",3)_"): "

 S XQAMSG=XQAMSG_"SPECIAL MEAL HAS BEEN "_FHAUSTT_" BY "_FHAUNAM

 D SETUP^XQALERT

 Q

UPD100 ;Backdoor message to update file #100 if SM order is denied

 Q:FHSTAT'="D"

 D PATNAME^FHOMUTL Q:'DFN

 S FHCATXT=FHCOMM D CNSM100^FHOMRC2

 Q

END ;

 K FHAUDA,FHAUNAM,FHAUSMDT,FHAUSTT,FHS,FHSTAT Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FHOMSA1   1998     printed  Mar 13, 2025@20:57:43                                                                                                                                                                                                     Page 2

FHOMSA1   ;Hines OIFO/RTK SPECIAL MEALS AUTHORIZE MEAL  ;4/11/03  12:55

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

 +2       ;

 +3        IF '$DATA(^XUSEC("FHAUTH",DUZ))

               WRITE !!!,"To access this option you most hold the 'FHAUTH' key!",!!

               HANG 3

               QUIT 

 +4        SET STDT=DT

           SET FHS="P"

           DO LIST^FHOMSS1

           WRITE !

 +5        IF NUM=0

               WRITE !,"NO PENDING SPECIAL MEALS TO AUTHORIZE"

               QUIT 

 +6        KILL DIR

           SET DIR("A")="Select Which Meal(s)?"

           SET DIR(0)="LO^1:"_NUM

           DO ^DIR

 +7        if $DATA(DIRUT)

               QUIT 

           SET FHCLST=Y

 +8        WRITE !

           KILL DIR

           SET DIR("A")="Authorize or Deny? "

 +9        SET DIR(0)="SAO^A:AUTHORIZE;D:DENY"

           SET DIR("B")="A"

           DO ^DIR

 +10       if $DATA(DIRUT)

               QUIT 

           SET FHSTAT=Y

 +11       IF FHSTAT="D"

               WRITE !

               KILL DIR

               SET DIR("A")="Comment: "

               SET DIR(0)="FA^1:80"

               DO ^DIR

               SET FHCOMM=Y

 +12       IF FHCOMM="^"

               WRITE !!?3,"Changes NOT saved!",!

               HANG 2

               QUIT 

 +13       WRITE !

           KILL DIR

           SET DIR("A")="Are you sure? "

           SET DIR(0)="YA"

           SET DIR("B")="Y"

           DO ^DIR

 +14       if $DATA(DIRUT)

               QUIT 

           IF Y=0

               DO END

               QUIT 

 +15       DO SIG^XUSESIG

           IF X1=""

               WRITE !!?5,"<< Incorrect Electronic Signature!! >>"

               QUIT 

 +16       FOR A=1:1:NUM

               SET FHC=$PIECE(FHCLST,",",A)

               if FHC=""

                   QUIT 

               SET FHCDT=FHLIST(FHC)

               DO UPD

               DO UPD100

 +17       WRITE "  ... done"

           QUIT 

 +18       QUIT 

UPD       ;Update the status,authorizor,date/time of special meal request

 +1        DO NOW^%DTC

           SET FHTODAY=$EXTRACT(%,1,12)

 +2        SET DA=$PIECE(FHCDT,U,2)

           SET FHDA=DA

           SET DA(1)=$PIECE(FHCDT,U,1)

           SET FHDFN=DA(1)

 +3        SET DIE="^FHPT("_DA(1)_",""SM"","

 +4        SET DR="1////^S X=FHSTAT;5////^S X=DUZ;6////^S X=FHTODAY;7////^S X=FHCOMM"

 +5        DO ^DIE

 +6        DO ALERT

 +7        SET FHZN=$GET(^FHPT(FHDFN,"SM",FHDA,0))

 +8        SET FHACT="O"

           SET FHOPTY="S"

           SET FHOPDT=$PIECE(FHTODAY,".",1)

           DO SETSM^FHOMRO2

 +9        QUIT 

ALERT     ;Send alert back to requestor

 +1        KILL XQA

           SET (FHAUDA,FHDFN)=$PIECE(FHCDT,U,1)

           SET FHAUSMDT=$PIECE(FHCDT,U,2)

 +2        SET FHREQ=$PIECE($GET(^FHPT(FHAUDA,"SM",FHAUSMDT,0)),U,5)

           IF FHREQ=""

               QUIT 

 +3        SET FHAUSTT=$SELECT(FHSTAT="A":"AUTHORIZED",1:"DENIED")

 +4        SET FHAUNAM=$PIECE($GET(^VA(200,DUZ,0)),U,1)

 +5        DO PATNAME^FHOMUTL

 +6        SET XQA(FHREQ)=""

 +7        SET XQAMSG=$EXTRACT(FHPTNM,1,9)_" ("_$EXTRACT(FHPTNM,1,1)_$PIECE(FHSSN,"-",3)_"): "

 +8        SET XQAMSG=XQAMSG_"SPECIAL MEAL HAS BEEN "_FHAUSTT_" BY "_FHAUNAM

 +9        DO SETUP^XQALERT

 +10       QUIT 

UPD100    ;Backdoor message to update file #100 if SM order is denied

 +1        if FHSTAT'="D"

               QUIT 

 +2        DO PATNAME^FHOMUTL

           if 'DFN

               QUIT 

 +3        SET FHCATXT=FHCOMM

           DO CNSM100^FHOMRC2

 +4        QUIT 

END       ;

 +1        KILL FHAUDA,FHAUNAM,FHAUSMDT,FHAUSTT,FHS,FHSTAT

           QUIT