HMPOR ;ASMR/CK,hrubovcak - Order file support;Feb 01, 2016 14:28:49
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2**;Build 4;Build 28
;Per VA Directive 6402, this routine should not be modified.
;
; routine created for US11894, December 17, 2015
Q
;
ADDFLAG(HMRSLT,HMVALS,HMORIFN,HMDFN,HMORLVL) ; LAYGO flag action into HMP SUBSCRIPTION file (#800000)
; HMRSLT - result, passed-by-ref., 1 on success else "-1^error message"
;parameters below required
; HMVALS - array of values, subscripted by field #, passed-by-ref.
; HMORIFN - Order IFN
; HMDFN - patient DFN
; HMORLVL = ^OR(100,HMORIFN,8,level) OPTIONAL, used from within OE/RR
;
S HMRSLT="-1^parameter missing" ; initialize return
Q:'($G(HMORIFN)>0)!'($G(HMDFN)>0) ; must have Order IFN and patient DFN
Q:'$G(HMVALS(.01)) ; must have date/time at minimum
;
N FMSG,HMFDA,HMIENS,HMSRVR,J,SUB,X
S HMSRVR=$$SRVRNO(HMDFN)
I '(HMSRVR>0) S HMRSLT="-1^HMP server not found to add flag data." Q
;
S X=$$GET1^DIQ(100,HMORIFN_",",.02,"I") ; (#.02) OBJECT OF ORDER
I '($P(X,";",2)="DPT(") S HMRSLT="-1^Order DFN not found" Q ; not a patient
S HMDFN=+X I '$D(^HMP(800000,HMSRVR,1,HMDFN,0)) S HMRSLT="-1^DFN "_HMDFN_" not subscribed." Q ; not subscribed
;
; If Order not in HMP sub-file then LAYGO it in
I '$D(^HMP(800000,HMSRVR,1,HMDFN,1,HMORIFN,0)) D
. N HMVALS,RSLT,VALS ; protect the values in HMVALS
. S VALS(.15)=$$NOW^XLFDT ; Order Action Date/Time
. D ADDORDR(.RSLT,.VALS,HMORIFN,HMDFN,HMORLVL) ; DE3584 Jan 27, 2016
;
S SUB="+1,"_HMORIFN_","_HMDFN_","_HMSRVR_","
F J=.01,.02,.03,.04 S:$G(HMVALS(J))]"" HMFDA(800000.142,SUB,J)=HMVALS(J)
D UPDATE^DIE("","HMFDA","HMIENS","FMSG") ; HMIENS coming back from call
;
D ; update date and time for lastUpdateTime in HMPSTMP
. N HMVALS,RSLT,VALS ; protect the values in HMVALS
. S VALS(.15)=$$NOW^XLFDT ; Order Action Date/Time
. D UPDTORDR(.RSLT,.VALS,HMORIFN,HMDFN)
;
S HMRSLT=$S($D(FMSG):"-^FM error in ADDFLAG",1:1)
;
Q
;
ADDORDR(HMRSLT,HMVALS,HMORIFN,HMDFN,HMORLVL) ; LAYGO order into HMP SUBSCRIPTION file (#800000), sub-file 800000.14
; HMRSLT - return value passed-by-ref., 1 on success else "-1^error message"
;parameters below required
; HMVALS - array of values, subscripted by field #, passed-by-ref.
; note: HMVALS(.01) not needed, it's the DINUM value below
; HMORIFN - Order IFN
; HMDFN - patient's DFN
; HMORLVL = ^OR(100,HMORIFN,8,level) OPTIONAL, used from within OE/RR
;
S HMRSLT="-1^parameter missing" ; initialize return
Q:'($G(HMORIFN)>0)!'($G(HMDFN)>0) ; must have Order IFN and DFN
Q:'$O(HMVALS(0)) ; must have FileMan data array
;
N A,FMSG,HMFDA,HMIENS,HMSRVR,J,L,SUB
S HMSRVR=$$SRVRNO(HMDFN) ; server number subscribed to
I '(HMSRVR>0) S HMRSLT="-1^HMP server not found for DFN "_HMDFN Q ; not subscribed
I $D(^HMP(800000,HMSRVR,1,HMDFN,1,"B",HMORIFN)) S HMRSLT="-1^ORDER "_HMORIFN_" already tracked." Q ; duplicate Order creation
;
S HMIENS(1)=HMORIFN ; new IEN assignment, DINUM relationship
S SUB="+1,"_HMDFN_","_HMSRVR_"," ; IENS subscript
S HMFDA(800000.14,SUB,.01)=HMORIFN
; loop below starts after .01 because of line above
S J=.01 F S J=$O(HMVALS(J)) Q:'J S HMFDA(800000.14,SUB,J)=HMVALS(J)
S HMFDA(800000.14,SUB,1.01)=$$NOW^XLFDT ; (#1.01) TRACKING START, Jan 26, 2016 - DE3584
D UPDATE^DIE("","HMFDA","HMIENS","FMSG")
; if duplicate IEN FileMan returns error
S HMRSLT=$S($D(FMSG):"-1^FM error in ADDORDR",1:1)
;DE3584 Jan 27, 2016
S L=+$G(HMORLVL) ; if >zero then call is from OE/RR (OPTIONAL)
S A=$P($G(HMORLVL),";",2) ; second ; piece is FLAG/UNFLAG (OPTIONAL)
;
; Jan 27, 2016 - DE3584 begin
D ; add any flag/unflag activity
. N RSLT,VALS,Y
. S J=0 F S J=$O(^OR(100,HMORIFN,8,J)) Q:'J D
.. S Y=$G(^OR(100,HMORIFN,8,J,3)) ; flag/unflag actions
.. I $P(Y,U,3) D ; always check for flag action first
... I L=J,A="F" Q ; call from OE/RR, Flag will be added there
... ; (#33) DATE/TIME FLAGGED [3D] ^ (#34) FLAGGED BY [4P:200] ^(#35) REASON FOR FLAG [5F]
... K RSLT,VALS S VALS(.01)=$P(Y,U,3),VALS(.02)="F",VALS(.03)=$P(Y,U,4),VALS(.04)=$P(Y,U,5)
... D ADDFLAG(.RSLT,.VALS,HMORIFN,HMDFN)
.. I $P(Y,U,6) D ; check for unflag action
... ; (#36) DATE/TIME UNFLAGGED [6D] ^ (#37) UNFLAGGED BY [7P:200] ^ (#38) REASON FOR UNFLAG [8F]
... I L=J,A="U" Q ; call from OE/RR, Unflag will be added there
... K RSLT,VALS S VALS(.01)=$P(Y,U,6),VALS(.02)="U",VALS(.03)=$P(Y,U,7),VALS(.04)=$P(Y,U,8)
... D ADDFLAG(.RSLT,.VALS,HMORIFN,HMDFN)
; Jan 27, 2016 - DE3584 end
Q
;
DELORDR(HMPDFN,HMIFN) ; delete entry in ORDERS sub-file
;
N DA,DIK,SRVNM
S SRVNM=$$SRVRNO(+$G(HMPDFN)) Q:'(SRVNM>0) ; get server number, quit if not found
S DIK="^HMP(800000,"_SRVNM_",1,"_(+$G(HMPDFN))_",1," ; needs server IEN and patient IEN
S DA=+$G(HMIFN),DA(1)=+$G(HMPDFN),DA(2)=SRVNM
D ^DIK
Q
;
ORDRCHK(HMORIFN,HMDFN) ; Boolean function, does ORDER number HMPORIFN exist in ^HMP(800000) for patient HMDFN
; DE3504 - Jan 19, 2016
N RSLT,SRVNM
S RSLT=0 ; default to zero
S SRVNM=$$SRVRNO(+$G(HMDFN)) Q:'(SRVNM>0) RSLT ; server not found, return zero ; Jan 26, 2016 - DE3584
S:$D(^HMP(800000,SRVNM,1,+$G(HMDFN),1,+$G(HMORIFN),0)) RSLT=1 ; order exists in ^HMP(800000)
Q RSLT
;
ORDRVALS(HMFLDS,HMORIFN) ; map ORDER ACTIONS (#100.008) to ORDERS sub-file (#800000.14) Feb 1, 2016
; HMFLDS returned by reference
; HMORIFN order IFN (Required)
;
N FLD,HMERR,HMIENS,HMORVALS,IEN,ORENTDT,SUBFL
K HMFLDS ; returned by reference
I '($G(HMORIFN)>0) S HMFLDS("ERR")="ORDER IEN required in routine "_$T(+0) Q
;
S HMIENS=(+HMORIFN)_"," ; IENS for Fileman
S ORENTDT=$$GET1^DIQ(100,HMIENS,4,"I") ; WHEN ENTERED, from ORDER file
D GETS^DIQ(100,HMIENS,".8*","IN","HMORVALS","HMERR") ; internal values, ignore null values
I $D(HMERR) M HMFLDS("ERR")=HMERR Q ; error returned from GETS^DIQ
; map HMFLDS (fields from ^OR(100)) to HMFLDS (fields in ^HMP(800000))
S SUBFL=100.008,IEN=""
S:ORENTDT HMFLDS(.02)=ORENTDT ; value stored outside of sub-file
F S IEN=$O(HMORVALS(SUBFL,IEN)) Q:'IEN D
. S FLD=0 F S FLD=$O(HMORVALS(SUBFL,IEN,FLD)) Q:'FLD S Y=HMORVALS(SUBFL,IEN,FLD,"I") D
.. S:FLD=5 HMFLDS(.03)=Y ; signed by
.. S:FLD=6 HMFLDS(.04)=Y ; signed date/time
.. S:FLD=8 HMFLDS(.05)=Y ; verifying nurse
.. S:FLD=9 HMFLDS(.06)=Y ; nurse verify date/time
.. S:FLD=10 HMFLDS(.07)=Y ; verifying clerk
.. S:FLD=11 HMFLDS(.08)=Y ; clerk verify date/time
.. S:FLD=18 HMFLDS(.09)=Y ; reviewed by
.. S:FLD=19 HMFLDS(.1)=Y ; reviewed date/time
.. S:FLD=17 HMFLDS(.11)=Y ; released by
.. S:FLD=16 HMFLDS(.12)=Y ; released by date/time
.. S:FLD=2 HMFLDS(.14)=Y ; order action
.. S:FLD=.01 HMFLDS(.15)=Y ; action date/time
;
Q
;
SRVRNO(DFN4SRVR) ; function, return server number for patient DFN4SRVR, zero if not subscribed
N SRVNM
S SRVNM=$O(^HMP(800000,"AITEM",+$G(DFN4SRVR),"")) ; server name
Q:SRVNM="" 0 ; patient not found
Q +$O(^HMP(800000,"B",SRVNM,0)) ; server IEN or zero
;
UPDTORDR(HMRSLT,HMVALS,HMORIFN,HMDFN) ; update order in HMP SUBSCRIPTION file (#800000), sub-file 800000.14
; HMRSLT - return value passed-by-ref., 1 on success else "-1^error message"
;all 3 parameters below required
; HMORIFN - Order IFN
; HMDFN - patient's DFN
; HMVALS - array of values, subscripted by field #, passed-by-ref.
; note: HMVALS(.01) not needed, it's the DINUM value below
;
S HMRSLT="-1^parameter missing" ; initialize return
Q:'($G(HMORIFN)>0)!'($G(HMDFN)>0) ; must have Order IFN and DFN
Q:'$O(HMVALS(0)) ; must have FileMan data
;
N FMSG,HMFDA,HMSRVR,J,SUB
S HMSRVR=$$SRVRNO(HMDFN) ; server number subscribed to
I '(HMSRVR>0) S HMRSLT="-1^HMP server not found for DFN "_HMDFN Q ; not subscribed
I '$D(^HMP(800000,HMSRVR,1,HMDFN,1,"B",HMORIFN)) S HMRSLT="-1^ORDER "_HMORIFN_" not found." Q ; Order must exist
;
S SUB=HMORIFN_","_HMDFN_","_HMSRVR_"," ; IENS subscript
; loop below starts after .01 because order already exists
S J=.01 F S J=$O(HMVALS(J)) Q:'J S HMFDA(800000.14,SUB,J)=HMVALS(J)
D FILE^DIE("","HMFDA","FMSG")
; return minus 1 if FileMan returns error
S HMRSLT=$S($D(FMSG):"-1^FM error in UPDTORDR",1:1)
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPOR 8318 printed Apr 09, 2024@20:59:57 Page 2
HMPOR ;ASMR/CK,hrubovcak - Order file support;Feb 01, 2016 14:28:49
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2**;Build 4;Build 28
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; routine created for US11894, December 17, 2015
+5 QUIT
+6 ;
ADDFLAG(HMRSLT,HMVALS,HMORIFN,HMDFN,HMORLVL) ; LAYGO flag action into HMP SUBSCRIPTION file (#800000)
+1 ; HMRSLT - result, passed-by-ref., 1 on success else "-1^error message"
+2 ;parameters below required
+3 ; HMVALS - array of values, subscripted by field #, passed-by-ref.
+4 ; HMORIFN - Order IFN
+5 ; HMDFN - patient DFN
+6 ; HMORLVL = ^OR(100,HMORIFN,8,level) OPTIONAL, used from within OE/RR
+7 ;
+8 ; initialize return
SET HMRSLT="-1^parameter missing"
+9 ; must have Order IFN and patient DFN
if '($GET(HMORIFN)>0)!'($GET(HMDFN)>0)
QUIT
+10 ; must have date/time at minimum
if '$GET(HMVALS(.01))
QUIT
+11 ;
+12 NEW FMSG,HMFDA,HMIENS,HMSRVR,J,SUB,X
+13 SET HMSRVR=$$SRVRNO(HMDFN)
+14 IF '(HMSRVR>0)
SET HMRSLT="-1^HMP server not found to add flag data."
QUIT
+15 ;
+16 ; (#.02) OBJECT OF ORDER
SET X=$$GET1^DIQ(100,HMORIFN_",",.02,"I")
+17 ; not a patient
IF '($PIECE(X,";",2)="DPT(")
SET HMRSLT="-1^Order DFN not found"
QUIT
+18 ; not subscribed
SET HMDFN=+X
IF '$DATA(^HMP(800000,HMSRVR,1,HMDFN,0))
SET HMRSLT="-1^DFN "_HMDFN_" not subscribed."
QUIT
+19 ;
+20 ; If Order not in HMP sub-file then LAYGO it in
+21 IF '$DATA(^HMP(800000,HMSRVR,1,HMDFN,1,HMORIFN,0))
Begin DoDot:1
+22 ; protect the values in HMVALS
NEW HMVALS,RSLT,VALS
+23 ; Order Action Date/Time
SET VALS(.15)=$$NOW^XLFDT
+24 ; DE3584 Jan 27, 2016
DO ADDORDR(.RSLT,.VALS,HMORIFN,HMDFN,HMORLVL)
End DoDot:1
+25 ;
+26 SET SUB="+1,"_HMORIFN_","_HMDFN_","_HMSRVR_","
+27 FOR J=.01,.02,.03,.04
if $GET(HMVALS(J))]""
SET HMFDA(800000.142,SUB,J)=HMVALS(J)
+28 ; HMIENS coming back from call
DO UPDATE^DIE("","HMFDA","HMIENS","FMSG")
+29 ;
+30 ; update date and time for lastUpdateTime in HMPSTMP
Begin DoDot:1
+31 ; protect the values in HMVALS
NEW HMVALS,RSLT,VALS
+32 ; Order Action Date/Time
SET VALS(.15)=$$NOW^XLFDT
+33 DO UPDTORDR(.RSLT,.VALS,HMORIFN,HMDFN)
End DoDot:1
+34 ;
+35 SET HMRSLT=$SELECT($DATA(FMSG):"-^FM error in ADDFLAG",1:1)
+36 ;
+37 QUIT
+38 ;
ADDORDR(HMRSLT,HMVALS,HMORIFN,HMDFN,HMORLVL) ; LAYGO order into HMP SUBSCRIPTION file (#800000), sub-file 800000.14
+1 ; HMRSLT - return value passed-by-ref., 1 on success else "-1^error message"
+2 ;parameters below required
+3 ; HMVALS - array of values, subscripted by field #, passed-by-ref.
+4 ; note: HMVALS(.01) not needed, it's the DINUM value below
+5 ; HMORIFN - Order IFN
+6 ; HMDFN - patient's DFN
+7 ; HMORLVL = ^OR(100,HMORIFN,8,level) OPTIONAL, used from within OE/RR
+8 ;
+9 ; initialize return
SET HMRSLT="-1^parameter missing"
+10 ; must have Order IFN and DFN
if '($GET(HMORIFN)>0)!'($GET(HMDFN)>0)
QUIT
+11 ; must have FileMan data array
if '$ORDER(HMVALS(0))
QUIT
+12 ;
+13 NEW A,FMSG,HMFDA,HMIENS,HMSRVR,J,L,SUB
+14 ; server number subscribed to
SET HMSRVR=$$SRVRNO(HMDFN)
+15 ; not subscribed
IF '(HMSRVR>0)
SET HMRSLT="-1^HMP server not found for DFN "_HMDFN
QUIT
+16 ; duplicate Order creation
IF $DATA(^HMP(800000,HMSRVR,1,HMDFN,1,"B",HMORIFN))
SET HMRSLT="-1^ORDER "_HMORIFN_" already tracked."
QUIT
+17 ;
+18 ; new IEN assignment, DINUM relationship
SET HMIENS(1)=HMORIFN
+19 ; IENS subscript
SET SUB="+1,"_HMDFN_","_HMSRVR_","
+20 SET HMFDA(800000.14,SUB,.01)=HMORIFN
+21 ; loop below starts after .01 because of line above
+22 SET J=.01
FOR
SET J=$ORDER(HMVALS(J))
if 'J
QUIT
SET HMFDA(800000.14,SUB,J)=HMVALS(J)
+23 ; (#1.01) TRACKING START, Jan 26, 2016 - DE3584
SET HMFDA(800000.14,SUB,1.01)=$$NOW^XLFDT
+24 DO UPDATE^DIE("","HMFDA","HMIENS","FMSG")
+25 ; if duplicate IEN FileMan returns error
+26 SET HMRSLT=$SELECT($DATA(FMSG):"-1^FM error in ADDORDR",1:1)
+27 ;DE3584 Jan 27, 2016
+28 ; if >zero then call is from OE/RR (OPTIONAL)
SET L=+$GET(HMORLVL)
+29 ; second ; piece is FLAG/UNFLAG (OPTIONAL)
SET A=$PIECE($GET(HMORLVL),";",2)
+30 ;
+31 ; Jan 27, 2016 - DE3584 begin
+32 ; add any flag/unflag activity
Begin DoDot:1
+33 NEW RSLT,VALS,Y
+34 SET J=0
FOR
SET J=$ORDER(^OR(100,HMORIFN,8,J))
if 'J
QUIT
Begin DoDot:2
+35 ; flag/unflag actions
SET Y=$GET(^OR(100,HMORIFN,8,J,3))
+36 ; always check for flag action first
IF $PIECE(Y,U,3)
Begin DoDot:3
+37 ; call from OE/RR, Flag will be added there
IF L=J
IF A="F"
QUIT
+38 ; (#33) DATE/TIME FLAGGED [3D] ^ (#34) FLAGGED BY [4P:200] ^(#35) REASON FOR FLAG [5F]
+39 KILL RSLT,VALS
SET VALS(.01)=$PIECE(Y,U,3)
SET VALS(.02)="F"
SET VALS(.03)=$PIECE(Y,U,4)
SET VALS(.04)=$PIECE(Y,U,5)
+40 DO ADDFLAG(.RSLT,.VALS,HMORIFN,HMDFN)
End DoDot:3
+41 ; check for unflag action
IF $PIECE(Y,U,6)
Begin DoDot:3
+42 ; (#36) DATE/TIME UNFLAGGED [6D] ^ (#37) UNFLAGGED BY [7P:200] ^ (#38) REASON FOR UNFLAG [8F]
+43 ; call from OE/RR, Unflag will be added there
IF L=J
IF A="U"
QUIT
+44 KILL RSLT,VALS
SET VALS(.01)=$PIECE(Y,U,6)
SET VALS(.02)="U"
SET VALS(.03)=$PIECE(Y,U,7)
SET VALS(.04)=$PIECE(Y,U,8)
+45 DO ADDFLAG(.RSLT,.VALS,HMORIFN,HMDFN)
End DoDot:3
End DoDot:2
End DoDot:1
+46 ; Jan 27, 2016 - DE3584 end
+47 QUIT
+48 ;
DELORDR(HMPDFN,HMIFN) ; delete entry in ORDERS sub-file
+1 ;
+2 NEW DA,DIK,SRVNM
+3 ; get server number, quit if not found
SET SRVNM=$$SRVRNO(+$GET(HMPDFN))
if '(SRVNM>0)
QUIT
+4 ; needs server IEN and patient IEN
SET DIK="^HMP(800000,"_SRVNM_",1,"_(+$GET(HMPDFN))_",1,"
+5 SET DA=+$GET(HMIFN)
SET DA(1)=+$GET(HMPDFN)
SET DA(2)=SRVNM
+6 DO ^DIK
+7 QUIT
+8 ;
ORDRCHK(HMORIFN,HMDFN) ; Boolean function, does ORDER number HMPORIFN exist in ^HMP(800000) for patient HMDFN
+1 ; DE3504 - Jan 19, 2016
+2 NEW RSLT,SRVNM
+3 ; default to zero
SET RSLT=0
+4 ; server not found, return zero ; Jan 26, 2016 - DE3584
SET SRVNM=$$SRVRNO(+$GET(HMDFN))
if '(SRVNM>0)
QUIT RSLT
+5 ; order exists in ^HMP(800000)
if $DATA(^HMP(800000,SRVNM,1,+$GET(HMDFN),1,+$GET(HMORIFN),0))
SET RSLT=1
+6 QUIT RSLT
+7 ;
ORDRVALS(HMFLDS,HMORIFN) ; map ORDER ACTIONS (#100.008) to ORDERS sub-file (#800000.14) Feb 1, 2016
+1 ; HMFLDS returned by reference
+2 ; HMORIFN order IFN (Required)
+3 ;
+4 NEW FLD,HMERR,HMIENS,HMORVALS,IEN,ORENTDT,SUBFL
+5 ; returned by reference
KILL HMFLDS
+6 IF '($GET(HMORIFN)>0)
SET HMFLDS("ERR")="ORDER IEN required in routine "_$TEXT(+0)
QUIT
+7 ;
+8 ; IENS for Fileman
SET HMIENS=(+HMORIFN)_","
+9 ; WHEN ENTERED, from ORDER file
SET ORENTDT=$$GET1^DIQ(100,HMIENS,4,"I")
+10 ; internal values, ignore null values
DO GETS^DIQ(100,HMIENS,".8*","IN","HMORVALS","HMERR")
+11 ; error returned from GETS^DIQ
IF $DATA(HMERR)
MERGE HMFLDS("ERR")=HMERR
QUIT
+12 ; map HMFLDS (fields from ^OR(100)) to HMFLDS (fields in ^HMP(800000))
+13 SET SUBFL=100.008
SET IEN=""
+14 ; value stored outside of sub-file
if ORENTDT
SET HMFLDS(.02)=ORENTDT
+15 FOR
SET IEN=$ORDER(HMORVALS(SUBFL,IEN))
if 'IEN
QUIT
Begin DoDot:1
+16 SET FLD=0
FOR
SET FLD=$ORDER(HMORVALS(SUBFL,IEN,FLD))
if 'FLD
QUIT
SET Y=HMORVALS(SUBFL,IEN,FLD,"I")
Begin DoDot:2
+17 ; signed by
if FLD=5
SET HMFLDS(.03)=Y
+18 ; signed date/time
if FLD=6
SET HMFLDS(.04)=Y
+19 ; verifying nurse
if FLD=8
SET HMFLDS(.05)=Y
+20 ; nurse verify date/time
if FLD=9
SET HMFLDS(.06)=Y
+21 ; verifying clerk
if FLD=10
SET HMFLDS(.07)=Y
+22 ; clerk verify date/time
if FLD=11
SET HMFLDS(.08)=Y
+23 ; reviewed by
if FLD=18
SET HMFLDS(.09)=Y
+24 ; reviewed date/time
if FLD=19
SET HMFLDS(.1)=Y
+25 ; released by
if FLD=17
SET HMFLDS(.11)=Y
+26 ; released by date/time
if FLD=16
SET HMFLDS(.12)=Y
+27 ; order action
if FLD=2
SET HMFLDS(.14)=Y
+28 ; action date/time
if FLD=.01
SET HMFLDS(.15)=Y
End DoDot:2
End DoDot:1
+29 ;
+30 QUIT
+31 ;
SRVRNO(DFN4SRVR) ; function, return server number for patient DFN4SRVR, zero if not subscribed
+1 NEW SRVNM
+2 ; server name
SET SRVNM=$ORDER(^HMP(800000,"AITEM",+$GET(DFN4SRVR),""))
+3 ; patient not found
if SRVNM=""
QUIT 0
+4 ; server IEN or zero
QUIT +$ORDER(^HMP(800000,"B",SRVNM,0))
+5 ;
UPDTORDR(HMRSLT,HMVALS,HMORIFN,HMDFN) ; update order in HMP SUBSCRIPTION file (#800000), sub-file 800000.14
+1 ; HMRSLT - return value passed-by-ref., 1 on success else "-1^error message"
+2 ;all 3 parameters below required
+3 ; HMORIFN - Order IFN
+4 ; HMDFN - patient's DFN
+5 ; HMVALS - array of values, subscripted by field #, passed-by-ref.
+6 ; note: HMVALS(.01) not needed, it's the DINUM value below
+7 ;
+8 ; initialize return
SET HMRSLT="-1^parameter missing"
+9 ; must have Order IFN and DFN
if '($GET(HMORIFN)>0)!'($GET(HMDFN)>0)
QUIT
+10 ; must have FileMan data
if '$ORDER(HMVALS(0))
QUIT
+11 ;
+12 NEW FMSG,HMFDA,HMSRVR,J,SUB
+13 ; server number subscribed to
SET HMSRVR=$$SRVRNO(HMDFN)
+14 ; not subscribed
IF '(HMSRVR>0)
SET HMRSLT="-1^HMP server not found for DFN "_HMDFN
QUIT
+15 ; Order must exist
IF '$DATA(^HMP(800000,HMSRVR,1,HMDFN,1,"B",HMORIFN))
SET HMRSLT="-1^ORDER "_HMORIFN_" not found."
QUIT
+16 ;
+17 ; IENS subscript
SET SUB=HMORIFN_","_HMDFN_","_HMSRVR_","
+18 ; loop below starts after .01 because order already exists
+19 SET J=.01
FOR
SET J=$ORDER(HMVALS(J))
if 'J
QUIT
SET HMFDA(800000.14,SUB,J)=HMVALS(J)
+20 DO FILE^DIE("","HMFDA","FMSG")
+21 ; return minus 1 if FileMan returns error
+22 SET HMRSLT=$SELECT($DATA(FMSG):"-1^FM error in UPDTORDR",1:1)
+23 ;
+24 QUIT
+25 ;
