- FHOMSP1 ;Hines OIFO/RTK SPECIAL MEALS PRINT MEAL ;4/11/03 8:05
- ;;5.5;DIETETICS;**2,5**;Jan 28, 2005;Build 53
- ;
- S STDT=DT,FHS="AP" D LIST^FHOMSS1 W !
- I NUM=0 W !,"NO AUTHORIZED OR PENDING SPECIAL MEALS TO PRINT" Q
- K DIR S DIR("A")="Print Which Meal(s)?",DIR(0)="LO^1:"_NUM D ^DIR
- Q:$D(DIRUT) S FHCLST=Y
- 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 DEV Q
- DEV ;get device and set up queue
- W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP
- I '$D(IO("Q")) U IO D PRINT,^%ZISC,END Q
- S ZTRTN="PRINT^FHOMSP1",ZTSAVE("STDT")="",ZTSAVE("FHDFN")=""
- S ZTSAVE("FHS")="",ZTSAVE("FHCDT")="",ZTSAVE("FHREQPR")=""
- S ZTSAVE("NUM")="",ZTSAVE("FHCLST")="",ZTSAVE("FHLIST(")=""
- S ZTDESC="Print Special Meals Voucher" D ^%ZTLOAD
- D ^%ZISC K %ZIS,IOP
- D END Q
- PRINT ;
- I $G(FHREQPR)=1 D PR2 Q
- F A=1:1:NUM S FHC=$P(FHCLST,",",A) Q:FHC="" S FHCDT=FHLIST(FHC) D PR2
- Q
- PR2 ;
- S FHDFN=$P(FHCDT,U,1) D PATNAME^FHOMUTL
- S FHD=$P(FHCDT,U,2),FHNODE=$G(^FHPT(FHDFN,"SM",FHD,0))
- D ALG^FHCLN S ALG="Allergies : "_$S(ALG="":"NONE ON FILE",1:ALG)
- S (LNS,UNLNS)="" F FHA=1:1:80 S LNS=LNS_"-",UNLNS=UNLNS_"_"
- S FHD=$E($$FMTE^XLFDT($P(FHCDT,U,2),"P"),1,12) S X=FHD D TR^FH S FHD=X
- S FHM=$P(FHNODE,U,9),FHSTAT=$P(FHNODE,U,2)
- S FHRQR=$P(FHNODE,U,5) S:FHRQR'="" FHRQR=$P($G(^VA(200,FHRQR,0)),U,1)
- S FHAZR=$P(FHNODE,U,6) S:FHAZR'="" FHAZR=$E($P($G(^VA(200,FHAZR,0)),U,1),1,20)
- S FHTTL=$P(FHNODE,U,6) S:FHTTL'="" FHTTL=$P($G(^VA(200,FHTTL,0)),U,9) I FHTTL'="" S FHTTL=$E($P($G(^DIC(3.1,FHTTL,0)),U,1),1,24)
- S FHMEAL=$S(FHM="B":"BREAKFAST",FHM="N":"NOON",1:"EVENING")
- S FHLPT=$P(FHNODE,U,3),FHLOC=$P($G(^FH(119.6,FHLPT,0)),U,1)
- S FHRMBD=$P(FHNODE,U,13),FHRMBNM=""
- I FHRMBD'="" S FHRMBNM=$E($P($G(^DG(405.4,FHRMBD,0)),U,1),1,24)
- S FHDPT=$P(FHNODE,U,4),FHDIET=$P($G(^FH(111,FHDPT,0)),U,1)
- W:$Y @IOF
- W !!!!,LNS,!?4," A U T H O R I Z E D O U T P A T I E N T M E A L V O U C H E R",!,LNS
- W !!!,"Name of Pt: ",$E(FHPTNM,1,20)," (",$E(FHPTNM,1,1),FHBID,")"
- W ?44,"Req Loc : ",$E(FHLOC,1,24)
- W !,"Start Date: ",FHD,?44,"Room-Bed : ",FHRMBNM
- W !,"Stop Date : ",FHD,?44,"Requestor: ",$E(FHRQR,1,24),!,ALG
- W !!?44,"Signature: ",$S(FHSTAT="A":"/es/"_FHAZR,1:$E(UNLNS,1,23))
- W !!?44," Title: ",$S(FHSTAT="A":FHTTL,1:$E(UNLNS,1,23))
- W !!?44," Date: ",$S(FHSTAT="A":FHD,1:$E(UNLNS,1,23))
- W !!!!,"Pt Authorized a: ",FHDIET," Meal for ",FHMEAL," meal time"
- W !!!!!!!!!!!!,"ALTERING OR COPYING THIS MEAL VOUCHER IS PROHIBITED."
- W !!!!!!!!!!!!!!!!!!,LNS,!,"In lieu of VA FORM 10-2817",!
- W !,"Facility: " D SITE^FH W SITE D NOW^%DTC W ?45,$$FMTE^XLFDT(%,"P")
- W !,LNS
- Q
- END ;
- K FHLPT,FHDPT,FHDIET,FHLOC,FHSTAT,FHRQR,FHTITL,FHAZR,FHMEAL Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHOMSP1 2745 printed Feb 18, 2025@23:19:28 Page 2
- FHOMSP1 ;Hines OIFO/RTK SPECIAL MEALS PRINT MEAL ;4/11/03 8:05
- +1 ;;5.5;DIETETICS;**2,5**;Jan 28, 2005;Build 53
- +2 ;
- +3 SET STDT=DT
- SET FHS="AP"
- DO LIST^FHOMSS1
- WRITE !
- +4 IF NUM=0
- WRITE !,"NO AUTHORIZED OR PENDING SPECIAL MEALS TO PRINT"
- QUIT
- +5 KILL DIR
- SET DIR("A")="Print Which Meal(s)?"
- SET DIR(0)="LO^1:"_NUM
- DO ^DIR
- +6 if $DATA(DIRUT)
- QUIT
- SET FHCLST=Y
- +7 WRITE !
- KILL DIR
- SET DIR("A")="Are you sure? "
- SET DIR(0)="YA"
- SET DIR("B")="Y"
- DO ^DIR
- +8 if $DATA(DIRUT)
- QUIT
- IF Y=0
- DO END
- QUIT
- +9 DO DEV
- QUIT
- DEV ;get device and set up queue
- +1 WRITE !
- KILL %ZIS,IOP
- SET %ZIS="Q"
- DO ^%ZIS
- if POP
- QUIT
- +2 IF '$DATA(IO("Q"))
- USE IO
- DO PRINT
- DO ^%ZISC
- DO END
- QUIT
- +3 SET ZTRTN="PRINT^FHOMSP1"
- SET ZTSAVE("STDT")=""
- SET ZTSAVE("FHDFN")=""
- +4 SET ZTSAVE("FHS")=""
- SET ZTSAVE("FHCDT")=""
- SET ZTSAVE("FHREQPR")=""
- +5 SET ZTSAVE("NUM")=""
- SET ZTSAVE("FHCLST")=""
- SET ZTSAVE("FHLIST(")=""
- +6 SET ZTDESC="Print Special Meals Voucher"
- DO ^%ZTLOAD
- +7 DO ^%ZISC
- KILL %ZIS,IOP
- +8 DO END
- QUIT
- PRINT ;
- +1 IF $GET(FHREQPR)=1
- DO PR2
- QUIT
- +2 FOR A=1:1:NUM
- SET FHC=$PIECE(FHCLST,",",A)
- if FHC=""
- QUIT
- SET FHCDT=FHLIST(FHC)
- DO PR2
- +3 QUIT
- PR2 ;
- +1 SET FHDFN=$PIECE(FHCDT,U,1)
- DO PATNAME^FHOMUTL
- +2 SET FHD=$PIECE(FHCDT,U,2)
- SET FHNODE=$GET(^FHPT(FHDFN,"SM",FHD,0))
- +3 DO ALG^FHCLN
- SET ALG="Allergies : "_$SELECT(ALG="":"NONE ON FILE",1:ALG)
- +4 SET (LNS,UNLNS)=""
- FOR FHA=1:1:80
- SET LNS=LNS_"-"
- SET UNLNS=UNLNS_"_"
- +5 SET FHD=$EXTRACT($$FMTE^XLFDT($PIECE(FHCDT,U,2),"P"),1,12)
- SET X=FHD
- DO TR^FH
- SET FHD=X
- +6 SET FHM=$PIECE(FHNODE,U,9)
- SET FHSTAT=$PIECE(FHNODE,U,2)
- +7 SET FHRQR=$PIECE(FHNODE,U,5)
- if FHRQR'=""
- SET FHRQR=$PIECE($GET(^VA(200,FHRQR,0)),U,1)
- +8 SET FHAZR=$PIECE(FHNODE,U,6)
- if FHAZR'=""
- SET FHAZR=$EXTRACT($PIECE($GET(^VA(200,FHAZR,0)),U,1),1,20)
- +9 SET FHTTL=$PIECE(FHNODE,U,6)
- if FHTTL'=""
- SET FHTTL=$PIECE($GET(^VA(200,FHTTL,0)),U,9)
- IF FHTTL'=""
- SET FHTTL=$EXTRACT($PIECE($GET(^DIC(3.1,FHTTL,0)),U,1),1,24)
- +10 SET FHMEAL=$SELECT(FHM="B":"BREAKFAST",FHM="N":"NOON",1:"EVENING")
- +11 SET FHLPT=$PIECE(FHNODE,U,3)
- SET FHLOC=$PIECE($GET(^FH(119.6,FHLPT,0)),U,1)
- +12 SET FHRMBD=$PIECE(FHNODE,U,13)
- SET FHRMBNM=""
- +13 IF FHRMBD'=""
- SET FHRMBNM=$EXTRACT($PIECE($GET(^DG(405.4,FHRMBD,0)),U,1),1,24)
- +14 SET FHDPT=$PIECE(FHNODE,U,4)
- SET FHDIET=$PIECE($GET(^FH(111,FHDPT,0)),U,1)
- +15 if $Y
- WRITE @IOF
- +16 WRITE !!!!,LNS,!?4," A U T H O R I Z E D O U T P A T I E N T M E A L V O U C H E R",!,LNS
- +17 WRITE !!!,"Name of Pt: ",$EXTRACT(FHPTNM,1,20)," (",$EXTRACT(FHPTNM,1,1),FHBID,")"
- +18 WRITE ?44,"Req Loc : ",$EXTRACT(FHLOC,1,24)
- +19 WRITE !,"Start Date: ",FHD,?44,"Room-Bed : ",FHRMBNM
- +20 WRITE !,"Stop Date : ",FHD,?44,"Requestor: ",$EXTRACT(FHRQR,1,24),!,ALG
- +21 WRITE !!?44,"Signature: ",$SELECT(FHSTAT="A":"/es/"_FHAZR,1:$EXTRACT(UNLNS,1,23))
- +22 WRITE !!?44," Title: ",$SELECT(FHSTAT="A":FHTTL,1:$EXTRACT(UNLNS,1,23))
- +23 WRITE !!?44," Date: ",$SELECT(FHSTAT="A":FHD,1:$EXTRACT(UNLNS,1,23))
- +24 WRITE !!!!,"Pt Authorized a: ",FHDIET," Meal for ",FHMEAL," meal time"
- +25 WRITE !!!!!!!!!!!!,"ALTERING OR COPYING THIS MEAL VOUCHER IS PROHIBITED."
- +26 WRITE !!!!!!!!!!!!!!!!!!,LNS,!,"In lieu of VA FORM 10-2817",!
- +27 WRITE !,"Facility: "
- DO SITE^FH
- WRITE SITE
- DO NOW^%DTC
- WRITE ?45,$$FMTE^XLFDT(%,"P")
- +28 WRITE !,LNS
- +29 QUIT
- END ;
- +1 KILL FHLPT,FHDPT,FHDIET,FHLOC,FHSTAT,FHRQR,FHTITL,FHAZR,FHMEAL
- QUIT