- FHORT3 ; HISC/REL/NCA - Tubefeeding Utilities ;8/9/96 11:41 ;
- ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
- EN1 ; Edit Tubefeeding Products
- S CHK=0,TYP="T",EVENT="UPD",REC=1,(NOD1,NOD3)="" K ^TMP($J,"FHNOD2")
- W ! S (DIC,DIE)="^FH(118.2,",DIC(0)="AEQLM",DIC("DR")=".01",DLAYGO=118.2 W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN1:Y<1
- S DA=+Y,IEN=Y,NOD1=$P($G(^FH(118.2,+IEN,0)),"^",1),NOD3=$G(^FH(118.2,+IEN,"I"))
- F IEN1=0:0 S IEN1=$O(^FH(118.2,+IEN,1,IEN1)) Q:IEN1<1 S:'$D(^TMP($J,"FHNOD2",IEN1)) ^TMP($J,"FHNOD2",IEN1)=$G(^FH(118.2,+IEN,1,IEN1,0))
- ;DR STRING MODIFIED TO ONLY EDIT INACTIVE STATUS IF TF PRODUCT INACTIVE
- S DR="I $G(^FH(118.2,+IEN,""I""))=""Y"" S Y=99;.01;1;2;S:X[""G"" Y=""@1"";3;@1;10:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=118.2 D ^DIE K DA,DIE,DIDEL,DR I $D(^ORD(101.43)) D UPDATE^FHWOR6
- G EN1
- EN2 ; List Tubefeeding Products
- W !!,"The list requires a 132 column printer.",!
- W ! S L=0,DIC="^FH(118.2,",FLDS="[FHTFLST]",BY="NAME"
- S FR="",TO="",DHD="TUBEFEEDING PRODUCTS" D EN1^DIP,RSET Q
- RSET K %ZIS S IOP="" D ^%ZIS K %ZIS,IOP,BY,DA,DHD,DIC,DIE,DR,FLDS,FR,L,TO,X,Y Q
- KIL K ^TMP($J),CHK,DIC,DIE,DTOUT,EVENT,IEN,IEN1,NOD1,NOD3,REC,TYP,X,Y Q
- POST ; Generate bulletin [NEW PATCH 8]
- S WRD=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",8)
- Q:'$D(^FH(119.6,+WRD,0))
- K XMY,XMB S XMB(1)=$P(^DPT(DFN,0),"^",1),XMB(2)=BID
- F FHXMKK=0:0 S FHXMKK=$O(^FH(119.6,WRD,2,"B",FHXMKK)) Q:FHXMKK'>0 D
- .S XMY(FHXMKK)=""
- Q:'$D(XMY) S XMB(4)=$S($D(^DPT(DFN,.101)):^(.101),1:"unknown")
- S XMB(5)="" I CAN S XMB(5)="Diet Orders"_$S(CAN=2:" and Supplemental Feedings",1:"")_" have been cancelled."
- S XMB(3)=$P(^FH(119.6,WRD,0),"^",1),XMB="FHDITF" D ^XMB
- K XMY,XMB,XMM,XMDT,FHXMKK Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORT3 1708 printed Mar 13, 2025@20:58:34 Page 2
- FHORT3 ; HISC/REL/NCA - Tubefeeding Utilities ;8/9/96 11:41 ;
- +1 ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
- EN1 ; Edit Tubefeeding Products
- +1 SET CHK=0
- SET TYP="T"
- SET EVENT="UPD"
- SET REC=1
- SET (NOD1,NOD3)=""
- KILL ^TMP($JOB,"FHNOD2")
- +2 WRITE !
- SET (DIC,DIE)="^FH(118.2,"
- SET DIC(0)="AEQLM"
- SET DIC("DR")=".01"
- SET DLAYGO=118.2
- WRITE !
- DO ^DIC
- KILL DIC,DLAYGO
- if U[X!$DATA(DTOUT)
- GOTO KIL
- if Y<1
- GOTO EN1
- +3 SET DA=+Y
- SET IEN=Y
- SET NOD1=$PIECE($GET(^FH(118.2,+IEN,0)),"^",1)
- SET NOD3=$GET(^FH(118.2,+IEN,"I"))
- +4 FOR IEN1=0:0
- SET IEN1=$ORDER(^FH(118.2,+IEN,1,IEN1))
- if IEN1<1
- QUIT
- if '$DATA(^TMP($JOB,"FHNOD2",IEN1))
- SET ^TMP($JOB,"FHNOD2",IEN1)=$GET(^FH(118.2,+IEN,1,IEN1,0))
- +5 ;DR STRING MODIFIED TO ONLY EDIT INACTIVE STATUS IF TF PRODUCT INACTIVE
- +6 SET DR="I $G(^FH(118.2,+IEN,""I""))=""Y"" S Y=99;.01;1;2;S:X[""G"" Y=""@1"";3;@1;10:99"
- if $DATA(^XUSEC("FHMGR",DUZ))
- SET DIDEL=118.2
- DO ^DIE
- KILL DA,DIE,DIDEL,DR
- IF $DATA(^ORD(101.43))
- DO UPDATE^FHWOR6
- +7 GOTO EN1
- EN2 ; List Tubefeeding Products
- +1 WRITE !!,"The list requires a 132 column printer.",!
- +2 WRITE !
- SET L=0
- SET DIC="^FH(118.2,"
- SET FLDS="[FHTFLST]"
- SET BY="NAME"
- +3 SET FR=""
- SET TO=""
- SET DHD="TUBEFEEDING PRODUCTS"
- DO EN1^DIP
- DO RSET
- QUIT
- RSET KILL %ZIS
- SET IOP=""
- DO ^%ZIS
- KILL %ZIS,IOP,BY,DA,DHD,DIC,DIE,DR,FLDS,FR,L,TO,X,Y
- QUIT
- KIL KILL ^TMP($JOB),CHK,DIC,DIE,DTOUT,EVENT,IEN,IEN1,NOD1,NOD3,REC,TYP,X,Y
- QUIT
- POST ; Generate bulletin [NEW PATCH 8]
- +1 SET WRD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",8)
- +2 if '$DATA(^FH(119.6,+WRD,0))
- QUIT
- +3 KILL XMY,XMB
- SET XMB(1)=$PIECE(^DPT(DFN,0),"^",1)
- SET XMB(2)=BID
- +4 FOR FHXMKK=0:0
- SET FHXMKK=$ORDER(^FH(119.6,WRD,2,"B",FHXMKK))
- if FHXMKK'>0
- QUIT
- Begin DoDot:1
- +5 SET XMY(FHXMKK)=""
- End DoDot:1
- +6 if '$DATA(XMY)
- QUIT
- SET XMB(4)=$SELECT($DATA(^DPT(DFN,.101)):^(.101),1:"unknown")
- +7 SET XMB(5)=""
- IF CAN
- SET XMB(5)="Diet Orders"_$SELECT(CAN=2:" and Supplemental Feedings",1:"")_" have been cancelled."
- +8 SET XMB(3)=$PIECE(^FH(119.6,WRD,0),"^",1)
- SET XMB="FHDITF"
- DO ^XMB
- +9 KILL XMY,XMB,XMM,XMDT,FHXMKK
- QUIT
