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 ---[H[J[2J[HFHOMSA1 1998 printed Dec 13, 2024@01:53:04 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
