FHWOR3 ; HISC/NCA - HL7 Early/Late Tray ;10/10/00 14:56
;;5.5;DIETETICS;;Jan 28, 2005
S DATA=X
N BAG,CODE,DATE,DAY,DTE,DP,EL,K,L1,LP,LSTWD,MEAL,PER,PIECE,SERV,SP,W1,WKD,WKDAYS,Y
S:ITVL="" ITVL="ONCE"
I 'SDT S TXT="No Start Date." D ERR^FHWOR Q
S DATE=SDT D CVT^FHWOR S SDT=DATE\1
I EDT S DATE=EDT D CVT^FHWOR S EDT=DATE\1
I 'EDT S:ITVL="ONCE" EDT=SDT I 'EDT S TXT="No Stop Date." D ERR^FHWOR Q
S SERV=$P(DATA,"|",2)
I $P("EARLY",SERV,1)'="",$P("LATE",SERV,1)'="" S TXT="Wrong Type of Tray." D ERR^FHWOR Q
S PER=$P(DATA,"|",3),PER=$E(PER,4,$L(PER)),MEAL=$E(PER,1) I "BNE"'[MEAL S TXT="Wrong Service Period." D ERR^FHWOR Q
I $E(PER,2)'=$E(SERV,1) S TXT="Wrong Service Period." D ERR^FHWOR Q
S PIECE=$E(PER,3) I 'PIECE S TXT="No Time Specified." D ERR^FHWOR Q
S K=$S(MEAL="B":0,MEAL="N":6,1:12)+($E(PER,2)="L"*3)
S W1=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",8),DP=$P($G(^FH(119.6,+W1,0)),"^",8)
K TM F L1=1:1:3 S TM(L1)=$P($G(^FH(119.73,+DP,1)),"^",K+L1)
S TIM=TM(PIECE) I TIM="" F L1=1:1:3 S:TM(L1)'="" TIM=TM(L1)
I TIM="" S TXT="No Early/Late Time on file." D ERR^FHWOR Q
S BAG="N" I $P(X,"|",4)="bagged" S BAG="Y"
S X=SDT_"@"_TIM,%DT="XT" D ^%DT S (SDT,FHDTIM)=Y,EDT=EDT+(SDT#1)
S (FHV1,FHV2)="" D CUR^FHWOR31(FHDFN,ADM,FHDTIM,.FHV1,.FHV2)
S (WKDAYS,WKD)=""
I SDT=EDT D G:SP ERR G PROC
.S SP="" F K=SDT\1:0 S K=$O(^FHPT(FHDFN,"A",ADM,"EL",K)) Q:K<1!(K\1'=(SDT\1)) I $P(^(K,0),"^",2)=MEAL S SP=K Q
.I SP S TXT="Early/Late Meal Already Ordered for this Date." Q
.Q
F LP=1:1 S CODE=$P(ITVL,"~",LP) Q:CODE="" D Q:TXT'=""
.I CODE="ONCE" S TXT="ONCE is for one Day Only." Q
.I $E(CODE,1)'="Q" S TXT="Wrong Interval specification. Use Only ONCE, QJ#, or Q1J#." Q
.I +$E(CODE,2)>1 S TXT="Wrong interval specification. Use Only ONCE, QJ#, or Q1J#." Q
.S LSTWD=$E(CODE,$L(CODE))
.I LSTWD="J" S DAY=1 S WKD=WKD_$E("MTWRFSX",DAY) Q
.I LSTWD?1N,$E(CODE,$L(CODE)-1)="J" D Q
..S DAY=LSTWD I DAY<1!(DAY>7) S TXT="Wrong Day Specification." Q
..S WKD=WKD_$E("MTWRFSX",DAY),WKDAYS=WKDAYS_DAY Q
.S TXT="Wrong interval specification. Use Only ONCE, QJ#, or Q1J#."
.Q
I TXT'="" D ERR^FHWOR Q
PROC ; Process Add E/L Trays
D PROC^FHWOR31
EXIT ; Exit Process Kill.
K %,%H,%I,%DT,BAG,CODE,DATE,DAY,DTE,DP,EL,FHDAY,FHDTIM,FHV1,FHV2,K,L1,LP,LSTWD,MEAL,PER,PIECE,SERV,SP,W1,WKD,WKDAYS,X,Y Q
ERR ; Send Error Message
D ERR^FHWOR Q
CAN ; Process Cancel/Discontinue from OE/RR
D NOW^%DTC S NOW=%,CT=0
D GADM^FHWORR
F EL=%:0 S EL=$O(^FHPT(FHDFN,"A",+ADM,"EL",EL)) Q:EL<1!(EL>$P(FILL,";",5)) S X=$G(^(EL,0)) I $P(X,"^",7)=+FHORN K ^FHPT(FHDFN,"A",ADM,"EL",EL),^FHPT("ADLT",EL,FHDFN) S CT=CT+1
S %=$S($D(^FHPT(FHDFN,"A",ADM,"EL",0)):$P(^(0),"^",4),1:0)-CT S:%'<0 $P(^(0),"^",4)=%
K %,%H,%I,CT,EL D CSEND^FHWOR Q
EL ; Code Early Late Tray
K MSG S WKDAYS=""
I SDT=EDT S ITVL="ONCE" G EL1
S ITVL="" F K=1:1 S Z=$E(WKD,K) Q:Z="" S DAY=$F("MTWRFSX",Z),DAY=DAY-1 S:ITVL'="" ITVL=ITVL_"~" S ITVL=ITVL_"QJ"_DAY,WKDAYS=WKDAYS_DAY
EL1 S FILL="E"_";"_ADM_";;"_SDT_";"_EDT_";"_WKD_";"_MEAL_";"_TIM_";"_BAG
D SET
; Code MSH, PID, and PV1
D MSH^FHWOR
; code ORC
S MSG(4)="ORC|SN||"_FILL_"^FH||||^"_ITVL_"^^"_SDT_"^"_EDT_"|||"_DUZ_"||"_DUZ_"|||"_NOW
; code ODT
S MSG(5)="ODT|"_$S(SERV="E":"EARLY",1:"LATE")_"|^^^"_MEAL_SERV_NUM_"^^99FHS|"_$S(BAG="Y":"bagged",1:"")
K FHWARD,FILL,HOSP,ITVL,FHORN,RM,SITE,WARD,WKDAYS,Z Q
CODE ; Code Cancel/Discontinue Early Late Tray
K MSG S ACT="OC",WKD="",CTR=0 D SITE^FH
S EDT="" F SK=0:0 S SK=$O(NN(FHORN,SK)) Q:SK<1 S CTR=CTR+1 S:CTR=1 SDT=SK S EDT=SK D WKD
S STR=$G(^FHPT(FHDFN,"A",ADM,"EL",EDT,0))
S FILL="E"_";"_ADM_";;"_SDT_";"_EDT_";"_WKD_";"_$P(STR,"^",2)_";"_$P(STR,"^",3)_";"_$P(STR,"^",4)
; code MSH
S MSG(1)="MSH|^~\&|DIETETICS|"_SITE(1)_"|||||ORM"
; code PID
S MSG(2)="PID|||"_DFN_"||"_$P($G(^DPT(DFN,0)),"^",1)
; code ORC
S DATE=$$FMTHL7^XLFDT(NOW)
S MSG(3)="ORC|"_ACT_"|"_FHORN_"^OR|"_FILL_"^FH|||||||||"_FHPV_"|||"_DATE_"|Dietetics Canceled Early/Late Tray order."
K %,%Y,ACT,DATE,EDT,FILL,FHORN,SDT,SK,SITE,STR,WKD Q
WKD ; Get week days
D WKD^FHWOR31
Q
SET ; Set Date/Time in HL7 format
D SET^FHWOR31
Q
NA ; OE/RR Number Assign
S SDT=$P(FILL,";",4),EDT=$P(FILL,";",5),WKD=$P(FILL,";",6),MEAL=$P(FILL,";",7),TIM=$P(FILL,";",8),DTE=SDT
G:'+FHORN KIL
G:'$D(^FHPT(FHDFN,"A",ADM,"EL",SDT,0)) KIL
I WKD="" S $P(^FHPT(FHDFN,"A",ADM,"EL",SDT,0),"^",7)=+FHORN G KIL
F EL=SDT\1:0 S EL=$O(^FHPT(FHDFN,"A",ADM,"EL",EL)) Q:EL<1!(EL>EDT) D
.Q:$P(^FHPT(FHDFN,"A",ADM,"EL",EL,0),"^",7)
.Q:$P(^FHPT(FHDFN,"A",ADM,"EL",EL,0),"^",2)'=MEAL
.Q:$P(^FHPT(FHDFN,"A",ADM,"EL",EL,0),"^",3)'=TIM
.S X=EL D H^%DTC S:%Y=0 %Y=7 Q:%Y<0
.S WKDAYS=$E("MTWRFSX",%Y) Q:WKDAYS=""
.S:"MTWRFSX"[WKDAYS $P(^FHPT(FHDFN,"A",ADM,"EL",EL,0),"^",7)=+FHORN
.Q
KIL K %Y,DTE,EDT,EL,NUM,MEAL,MSG,FHORN,SDT,TIM,WKDAYS,WKD Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHWOR3 4867 printed Nov 22, 2024@17:05:33 Page 2
FHWOR3 ; HISC/NCA - HL7 Early/Late Tray ;10/10/00 14:56
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 SET DATA=X
+3 NEW BAG,CODE,DATE,DAY,DTE,DP,EL,K,L1,LP,LSTWD,MEAL,PER,PIECE,SERV,SP,W1,WKD,WKDAYS,Y
+4 if ITVL=""
SET ITVL="ONCE"
+5 IF 'SDT
SET TXT="No Start Date."
DO ERR^FHWOR
QUIT
+6 SET DATE=SDT
DO CVT^FHWOR
SET SDT=DATE\1
+7 IF EDT
SET DATE=EDT
DO CVT^FHWOR
SET EDT=DATE\1
+8 IF 'EDT
if ITVL="ONCE"
SET EDT=SDT
IF 'EDT
SET TXT="No Stop Date."
DO ERR^FHWOR
QUIT
+9 SET SERV=$PIECE(DATA,"|",2)
+10 IF $PIECE("EARLY",SERV,1)'=""
IF $PIECE("LATE",SERV,1)'=""
SET TXT="Wrong Type of Tray."
DO ERR^FHWOR
QUIT
+11 SET PER=$PIECE(DATA,"|",3)
SET PER=$EXTRACT(PER,4,$LENGTH(PER))
SET MEAL=$EXTRACT(PER,1)
IF "BNE"'[MEAL
SET TXT="Wrong Service Period."
DO ERR^FHWOR
QUIT
+12 IF $EXTRACT(PER,2)'=$EXTRACT(SERV,1)
SET TXT="Wrong Service Period."
DO ERR^FHWOR
QUIT
+13 SET PIECE=$EXTRACT(PER,3)
IF 'PIECE
SET TXT="No Time Specified."
DO ERR^FHWOR
QUIT
+14 SET K=$SELECT(MEAL="B":0,MEAL="N":6,1:12)+($EXTRACT(PER,2)="L"*3)
+15 SET W1=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",8)
SET DP=$PIECE($GET(^FH(119.6,+W1,0)),"^",8)
+16 KILL TM
FOR L1=1:1:3
SET TM(L1)=$PIECE($GET(^FH(119.73,+DP,1)),"^",K+L1)
+17 SET TIM=TM(PIECE)
IF TIM=""
FOR L1=1:1:3
if TM(L1)'=""
SET TIM=TM(L1)
+18 IF TIM=""
SET TXT="No Early/Late Time on file."
DO ERR^FHWOR
QUIT
+19 SET BAG="N"
IF $PIECE(X,"|",4)="bagged"
SET BAG="Y"
+20 SET X=SDT_"@"_TIM
SET %DT="XT"
DO ^%DT
SET (SDT,FHDTIM)=Y
SET EDT=EDT+(SDT#1)
+21 SET (FHV1,FHV2)=""
DO CUR^FHWOR31(FHDFN,ADM,FHDTIM,.FHV1,.FHV2)
+22 SET (WKDAYS,WKD)=""
+23 IF SDT=EDT
Begin DoDot:1
+24 SET SP=""
FOR K=SDT\1:0
SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"EL",K))
if K<1!(K\1'=(SDT\1))
QUIT
IF $PIECE(^(K,0),"^",2)=MEAL
SET SP=K
QUIT
+25 IF SP
SET TXT="Early/Late Meal Already Ordered for this Date."
QUIT
+26 QUIT
End DoDot:1
if SP
GOTO ERR
GOTO PROC
+27 FOR LP=1:1
SET CODE=$PIECE(ITVL,"~",LP)
if CODE=""
QUIT
Begin DoDot:1
+28 IF CODE="ONCE"
SET TXT="ONCE is for one Day Only."
QUIT
+29 IF $EXTRACT(CODE,1)'="Q"
SET TXT="Wrong Interval specification. Use Only ONCE, QJ#, or Q1J#."
QUIT
+30 IF +$EXTRACT(CODE,2)>1
SET TXT="Wrong interval specification. Use Only ONCE, QJ#, or Q1J#."
QUIT
+31 SET LSTWD=$EXTRACT(CODE,$LENGTH(CODE))
+32 IF LSTWD="J"
SET DAY=1
SET WKD=WKD_$EXTRACT("MTWRFSX",DAY)
QUIT
+33 IF LSTWD?1N
IF $EXTRACT(CODE,$LENGTH(CODE)-1)="J"
Begin DoDot:2
+34 SET DAY=LSTWD
IF DAY<1!(DAY>7)
SET TXT="Wrong Day Specification."
QUIT
+35 SET WKD=WKD_$EXTRACT("MTWRFSX",DAY)
SET WKDAYS=WKDAYS_DAY
QUIT
End DoDot:2
QUIT
+36 SET TXT="Wrong interval specification. Use Only ONCE, QJ#, or Q1J#."
+37 QUIT
End DoDot:1
if TXT'=""
QUIT
+38 IF TXT'=""
DO ERR^FHWOR
QUIT
PROC ; Process Add E/L Trays
+1 DO PROC^FHWOR31
EXIT ; Exit Process Kill.
+1 KILL %,%H,%I,%DT,BAG,CODE,DATE,DAY,DTE,DP,EL,FHDAY,FHDTIM,FHV1,FHV2,K,L1,LP,LSTWD,MEAL,PER,PIECE,SERV,SP,W1,WKD,WKDAYS,X,Y
QUIT
ERR ; Send Error Message
+1 DO ERR^FHWOR
QUIT
CAN ; Process Cancel/Discontinue from OE/RR
+1 DO NOW^%DTC
SET NOW=%
SET CT=0
+2 DO GADM^FHWORR
+3 FOR EL=%:0
SET EL=$ORDER(^FHPT(FHDFN,"A",+ADM,"EL",EL))
if EL<1!(EL>$PIECE(FILL,";",5))
QUIT
SET X=$GET(^(EL,0))
IF $PIECE(X,"^",7)=+FHORN
KILL ^FHPT(FHDFN,"A",ADM,"EL",EL),^FHPT("ADLT",EL,FHDFN)
SET CT=CT+1
+4 SET %=$SELECT($DATA(^FHPT(FHDFN,"A",ADM,"EL",0)):$PIECE(^(0),"^",4),1:0)-CT
if %'<0
SET $PIECE(^(0),"^",4)=%
+5 KILL %,%H,%I,CT,EL
DO CSEND^FHWOR
QUIT
EL ; Code Early Late Tray
+1 KILL MSG
SET WKDAYS=""
+2 IF SDT=EDT
SET ITVL="ONCE"
GOTO EL1
+3 SET ITVL=""
FOR K=1:1
SET Z=$EXTRACT(WKD,K)
if Z=""
QUIT
SET DAY=$FIND("MTWRFSX",Z)
SET DAY=DAY-1
if ITVL'=""
SET ITVL=ITVL_"~"
SET ITVL=ITVL_"QJ"_DAY
SET WKDAYS=WKDAYS_DAY
EL1 SET FILL="E"_";"_ADM_";;"_SDT_";"_EDT_";"_WKD_";"_MEAL_";"_TIM_";"_BAG
+1 DO SET
+2 ; Code MSH, PID, and PV1
+3 DO MSH^FHWOR
+4 ; code ORC
+5 SET MSG(4)="ORC|SN||"_FILL_"^FH||||^"_ITVL_"^^"_SDT_"^"_EDT_"|||"_DUZ_"||"_DUZ_"|||"_NOW
+6 ; code ODT
+7 SET MSG(5)="ODT|"_$SELECT(SERV="E":"EARLY",1:"LATE")_"|^^^"_MEAL_SERV_NUM_"^^99FHS|"_$SELECT(BAG="Y":"bagged",1:"")
+8 KILL FHWARD,FILL,HOSP,ITVL,FHORN,RM,SITE,WARD,WKDAYS,Z
QUIT
CODE ; Code Cancel/Discontinue Early Late Tray
+1 KILL MSG
SET ACT="OC"
SET WKD=""
SET CTR=0
DO SITE^FH
+2 SET EDT=""
FOR SK=0:0
SET SK=$ORDER(NN(FHORN,SK))
if SK<1
QUIT
SET CTR=CTR+1
if CTR=1
SET SDT=SK
SET EDT=SK
DO WKD
+3 SET STR=$GET(^FHPT(FHDFN,"A",ADM,"EL",EDT,0))
+4 SET FILL="E"_";"_ADM_";;"_SDT_";"_EDT_";"_WKD_";"_$PIECE(STR,"^",2)_";"_$PIECE(STR,"^",3)_";"_$PIECE(STR,"^",4)
+5 ; code MSH
+6 SET MSG(1)="MSH|^~\&|DIETETICS|"_SITE(1)_"|||||ORM"
+7 ; code PID
+8 SET MSG(2)="PID|||"_DFN_"||"_$PIECE($GET(^DPT(DFN,0)),"^",1)
+9 ; code ORC
+10 SET DATE=$$FMTHL7^XLFDT(NOW)
+11 SET MSG(3)="ORC|"_ACT_"|"_FHORN_"^OR|"_FILL_"^FH|||||||||"_FHPV_"|||"_DATE_"|Dietetics Canceled Early/Late Tray order."
+12 KILL %,%Y,ACT,DATE,EDT,FILL,FHORN,SDT,SK,SITE,STR,WKD
QUIT
WKD ; Get week days
+1 DO WKD^FHWOR31
+2 QUIT
SET ; Set Date/Time in HL7 format
+1 DO SET^FHWOR31
+2 QUIT
NA ; OE/RR Number Assign
+1 SET SDT=$PIECE(FILL,";",4)
SET EDT=$PIECE(FILL,";",5)
SET WKD=$PIECE(FILL,";",6)
SET MEAL=$PIECE(FILL,";",7)
SET TIM=$PIECE(FILL,";",8)
SET DTE=SDT
+2 if '+FHORN
GOTO KIL
+3 if '$DATA(^FHPT(FHDFN,"A",ADM,"EL",SDT,0))
GOTO KIL
+4 IF WKD=""
SET $PIECE(^FHPT(FHDFN,"A",ADM,"EL",SDT,0),"^",7)=+FHORN
GOTO KIL
+5 FOR EL=SDT\1:0
SET EL=$ORDER(^FHPT(FHDFN,"A",ADM,"EL",EL))
if EL<1!(EL>EDT)
QUIT
Begin DoDot:1
+6 if $PIECE(^FHPT(FHDFN,"A",ADM,"EL",EL,0),"^",7)
QUIT
+7 if $PIECE(^FHPT(FHDFN,"A",ADM,"EL",EL,0),"^",2)'=MEAL
QUIT
+8 if $PIECE(^FHPT(FHDFN,"A",ADM,"EL",EL,0),"^",3)'=TIM
QUIT
+9 SET X=EL
DO H^%DTC
if %Y=0
SET %Y=7
if %Y<0
QUIT
+10 SET WKDAYS=$EXTRACT("MTWRFSX",%Y)
if WKDAYS=""
QUIT
+11 if "MTWRFSX"[WKDAYS
SET $PIECE(^FHPT(FHDFN,"A",ADM,"EL",EL,0),"^",7)=+FHORN
+12 QUIT
End DoDot:1
KIL KILL %Y,DTE,EDT,EL,NUM,MEAL,MSG,FHORN,SDT,TIM,WKDAYS,WKD
QUIT
