BQIGPORD ;VNGT/HS/BEE-Group Order Entry ; 17 Jun 2011 12:38 PM
;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
;
ORD(DATA,DFN,PARMS) ;EP -- BQI GROUP ORDER ENTRY
;
NEW UID,II,HDR,IX,LIST,PC,LST,ORDTEXT,OUTLST,BQIDX,VFIEN
NEW BQIORD,BQISTDT,BQITEXT,BQIPROV,BQILOC,ORDITM,ORDNAM,BQ
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIGPORD",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIGPORD D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
;Define Header
S HDR="T00001RESULT^T00050ERROR_MESSAGE^I00010DFN^I00010ORDER_NUMBER"_$C(30)
S @DATA@(II)=HDR
;
S VFIEN=$O(^BQI(90506.3,"B","Group Order Entry",""))
I VFIEN="" S BMXSEC="RPC Call Failed: Group Order Entry" Q
;
S DFN=$G(DFN,"")
;
S PARMS=$G(PARMS,"")
I PARMS="" D
. N LIST,BN
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
;Pull Parameter Data
F BQ=1:1:$L(PARMS,$C(28)) D Q:$G(BMXSEC)'=""
. N CHIEN,FIELD,NAME,PDATA,PFIEN,PTYP,VALUE
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1) I NAME="" Q
. S VALUE=$P(PDATA,"=",2,99)
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S FIELD=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
. I VALUE="",FIELD'=".001" S VALUE="@"
. S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
. I PTYP="D"!(PTYP="A") S VALUE=$$DATE^BQIUL1(VALUE)
. I PTYP="C" D
.. S CHIEN=$O(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
.. S VALUE=$P(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
. S @NAME=VALUE
;
;Set up information for API call
S LST(1,"DFN")=DFN
S LST(1,"PRV")=BQIPROV
S:$G(BQIDX)]"" LST(1,"CLN")=BQIDX
;
S ORDITM=$$GET1^DIQ(90621,BQIORD_",",.11,"I") G DONE:ORDITM=""
S ORDNAM=$$GET1^DIQ(101.43,ORDITM_",",.01,"E")
;
S ORDTEXT(1,0)=ORDNAM_" created from Group Order entry in iCare."
;
;Parse out incoming text
N CNT,I,LN,CH,LINE
S CNT=1 F I=1:1 Q:$L(BQITEXT)=0 D
. S LN=$E(BQITEXT,1,80)
. F CH=$L(LN):-1:1 I $E(LN,CH)=" " Q
. I $L(BQITEXT)<81 S BQITEXT="",LINE=LN
. E I CH>1 S BQITEXT=$E(BQITEXT,CH+1,999999),LINE=$E(LN,1,CH-1)
. E S BQITEXT=$E(BQITEXT,81,999999),LINE=LN
. S CNT=CNT+1,ORDTEXT(CNT,0)=LINE
S ORDTEXT(0)="^100.0451^"_CNT_U_CNT_U_DT_U_U
K CNT,I,LN,CH,LINE
;
;Check for duplicate orders
;
;Pull all active orders
D AGET^ORWORR("",DFN,2,"","","","")
I $D(^TMP("ORR",$J)) D
. ;
. ;Look for duplicate order
. NEW ORLIST,CNT,ORD
. S ORLIST="" F S ORLIST=$O(^TMP("ORR",$J,ORLIST)) Q:ORLIST="" D Q:$D(OUTLST)
.. S CNT=.1 F S CNT=$O(^TMP("ORR",$J,ORLIST,CNT)) Q:'CNT D Q:$D(OUTLST)
... S ORD=$P($P($G(^TMP("ORR",$J,ORLIST,CNT)),U),";")
... I $D(^OR(100,ORD,.1,"B",ORDITM)) S OUTLST(1)="^^DUPLICATE ORDER - ORIGINAL ORDER #"_ORD
. K ^TMP("ORR",$J)
;
;Call Group Order API
I '$D(OUTLST) D GRPORD^BEHOOGP(.OUTLST,.LST,ORDITM,BQISTDT,BQILOC,"",.ORDTEXT)
;
;Return Success/Failure Information
S II=$G(II)+1
I $P($G(OUTLST(1)),U,3)="ORDER CREATED" S @DATA@(II)="1^"_U_DFN_U_$P(OUTLST(1),U,2)_$C(30)
I $G(OUTLST(0))'="" S @DATA@(II)="0^"_$G(OUTLST(0))_U_DFN_U_$C(30)
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
MACT(DATA,FAKE) ;EP -- BQI CHK SCR MAMM STS
NEW UID,II,ACTIVE,DIC,X,IEN,Y
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIGPORD",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIGPORD D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="T00001ACTIVE"_$C(30)
;
S ACTIVE="Y"
S DIC="^ORD(101.43,",DIC(0)="X"
S X="SCREENING MAMMOGRAM"
D ^DIC
S IEN=+Y
I IEN="-1" S ACTIVE="N" G XMACT
;
;Check if INACTIVE
S X=$$GET1^DIQ(101.43,IEN_",",.1,"I")
I X]"",X<DT S ACTIVE="N"
;
XMACT S II=II+1,@DATA@(II)=ACTIVE_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
BQIGPORD ;VNGT/HS/BEE-Group Order Entry ; 17 Jun 2011 12:38 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
+2 ;
ORD(DATA,DFN,PARMS) ;EP -- BQI GROUP ORDER ENTRY
+1 ;
+2 NEW UID,II,HDR,IX,LIST,PC,LST,ORDTEXT,OUTLST,BQIDX,VFIEN
+3 NEW BQIORD,BQISTDT,BQITEXT,BQIPROV,BQILOC,ORDITM,ORDNAM,BQ
+4 ;
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("BQIGPORD",UID))
+7 KILL @DATA
+8 SET II=0
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIGPORD D UNWIND^%ZTER"
+10 ;
+11 ;Define Header
+12 SET HDR="T00001RESULT^T00050ERROR_MESSAGE^I00010DFN^I00010ORDER_NUMBER"_$CHAR(30)
+13 SET @DATA@(II)=HDR
+14 ;
+15 SET VFIEN=$ORDER(^BQI(90506.3,"B","Group Order Entry",""))
+16 IF VFIEN=""
SET BMXSEC="RPC Call Failed: Group Order Entry"
QUIT
+17 ;
+18 SET DFN=$GET(DFN,"")
+19 ;
+20 SET PARMS=$GET(PARMS,"")
+21 IF PARMS=""
Begin DoDot:1
+22 NEW LIST,BN
+23 SET LIST=""
SET BN=""
+24 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+25 KILL PARMS
+26 SET PARMS=LIST
+27 KILL LIST
End DoDot:1
+28 ;
+29 ;Pull Parameter Data
+30 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+31 NEW CHIEN,FIELD,NAME,PDATA,PFIEN,PTYP,VALUE
+32 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+33 SET NAME=$PIECE(PDATA,"=",1)
IF NAME=""
QUIT
+34 SET VALUE=$PIECE(PDATA,"=",2,99)
+35 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+36 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+37 SET FIELD=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
+38 IF VALUE=""
IF FIELD'=".001"
SET VALUE="@"
+39 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+40 IF PTYP="D"!(PTYP="A")
SET VALUE=$$DATE^BQIUL1(VALUE)
+41 IF PTYP="C"
Begin DoDot:2
+42 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+43 SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+44 SET @NAME=VALUE
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+45 ;
+46 ;Set up information for API call
+47 SET LST(1,"DFN")=DFN
+48 SET LST(1,"PRV")=BQIPROV
+49 IF $GET(BQIDX)]""
SET LST(1,"CLN")=BQIDX
+50 ;
+51 SET ORDITM=$$GET1^DIQ(90621,BQIORD_",",.11,"I")
IF ORDITM=""
GOTO DONE
+52 SET ORDNAM=$$GET1^DIQ(101.43,ORDITM_",",.01,"E")
+53 ;
+54 SET ORDTEXT(1,0)=ORDNAM_" created from Group Order entry in iCare."
+55 ;
+56 ;Parse out incoming text
+57 NEW CNT,I,LN,CH,LINE
+58 SET CNT=1
FOR I=1:1
IF $LENGTH(BQITEXT)=0
QUIT
Begin DoDot:1
+59 SET LN=$EXTRACT(BQITEXT,1,80)
+60 FOR CH=$LENGTH(LN):-1:1
IF $EXTRACT(LN,CH)=" "
QUIT
+61 IF $LENGTH(BQITEXT)<81
SET BQITEXT=""
SET LINE=LN
+62 IF '$TEST
IF CH>1
SET BQITEXT=$EXTRACT(BQITEXT,CH+1,999999)
SET LINE=$EXTRACT(LN,1,CH-1)
+63 IF '$TEST
SET BQITEXT=$EXTRACT(BQITEXT,81,999999)
SET LINE=LN
+64 SET CNT=CNT+1
SET ORDTEXT(CNT,0)=LINE
End DoDot:1
+65 SET ORDTEXT(0)="^100.0451^"_CNT_U_CNT_U_DT_U_U
+66 KILL CNT,I,LN,CH,LINE
+67 ;
+68 ;Check for duplicate orders
+69 ;
+70 ;Pull all active orders
+71 DO AGET^ORWORR("",DFN,2,"","","","")
+72 IF $DATA(^TMP("ORR",$JOB))
Begin DoDot:1
+73 ;
+74 ;Look for duplicate order
+75 NEW ORLIST,CNT,ORD
+76 SET ORLIST=""
FOR
SET ORLIST=$ORDER(^TMP("ORR",$JOB,ORLIST))
IF ORLIST=""
QUIT
Begin DoDot:2
+77 SET CNT=.1
FOR
SET CNT=$ORDER(^TMP("ORR",$JOB,ORLIST,CNT))
IF 'CNT
QUIT
Begin DoDot:3
+78 SET ORD=$PIECE($PIECE($GET(^TMP("ORR",$JOB,ORLIST,CNT)),U),";")
+79 IF $DATA(^OR(100,ORD,.1,"B",ORDITM))
SET OUTLST(1)="^^DUPLICATE ORDER - ORIGINAL ORDER #"_ORD
End DoDot:3
IF $DATA(OUTLST)
QUIT
End DoDot:2
IF $DATA(OUTLST)
QUIT
+80 KILL ^TMP("ORR",$JOB)
End DoDot:1
+81 ;
+82 ;Call Group Order API
+83 IF '$DATA(OUTLST)
DO GRPORD^BEHOOGP(.OUTLST,.LST,ORDITM,BQISTDT,BQILOC,"",.ORDTEXT)
+84 ;
+85 ;Return Success/Failure Information
+86 SET II=$GET(II)+1
+87 IF $PIECE($GET(OUTLST(1)),U,3)="ORDER CREATED"
SET @DATA@(II)="1^"_U_DFN_U_$PIECE(OUTLST(1),U,2)_$CHAR(30)
+88 IF $GET(OUTLST(0))'=""
SET @DATA@(II)="0^"_$GET(OUTLST(0))_U_DFN_U_$CHAR(30)
+89 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
MACT(DATA,FAKE) ;EP -- BQI CHK SCR MAMM STS
+1 NEW UID,II,ACTIVE,DIC,X,IEN,Y
+2 ;
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIGPORD",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIGPORD D UNWIND^%ZTER"
+9 SET @DATA@(II)="T00001ACTIVE"_$CHAR(30)
+10 ;
+11 SET ACTIVE="Y"
+12 SET DIC="^ORD(101.43,"
SET DIC(0)="X"
+13 SET X="SCREENING MAMMOGRAM"
+14 DO ^DIC
+15 SET IEN=+Y
+16 IF IEN="-1"
SET ACTIVE="N"
GOTO XMACT
+17 ;
+18 ;Check if INACTIVE
+19 SET X=$$GET1^DIQ(101.43,IEN_",",.1,"I")
+20 IF X]""
IF X<DT
SET ACTIVE="N"
+21 ;
XMACT SET II=II+1
SET @DATA@(II)=ACTIVE_$CHAR(30)
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
