ORWDXC ; SLC/KCM - Utilities for Order Checking;23-Nov-2011 11:50;PLS
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,141,1005,221,243,1010**;Dec 17, 1997;Build 47
; Modified - IHS/MSC/DKM - Added RENEW and MANUAL EP
ON(VAL) ; returns E if order checking enabled, otherwise D
S VAL=$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")
Q
FILLID(VAL,DLG) ; Return the FillerID (namespace) for a dialog
N DGRP
S VAL="",DGRP=$P($G(^ORD(101.41,DLG,0)),U,5) Q:'DGRP
S DLG=$$DEFDLG^ORWDXQ(DGRP)
S VAL=$P($G(^ORD(101.41,DLG,0)),U,7),VAL=$$NMSP^ORCD(VAL)
I VAL="PS" D
. N X
. S X=$P($P($G(^ORD(100.98,DGRP,0)),U,3)," ")
. I $L(X) S VAL="PS"_$S(X="UD":"I",1:X)
Q
DISPLAY(LST,DFN,FID) ; Return list of Order Checks for a FillerID (namespace)
N I,ORX,ORY
S ORX=1,ORX(1)="|"_FID
D EN^ORKCHK(.ORY,DFN,.ORX,"DISPLAY")
S I=0 F S I=$O(ORY(I)) Q:I'>0 S LST(I)=$P(ORY(I),U,4)
Q
; IHS/MSC/DKM - Added RENEW entry point
RENEW(LST,DFN,ORLST) ;
N X,Y,ORL,ORD,PID,INST,ITM,PKG,LP,CNT
S:$D(ORLST)=1 ORLST(1)=ORLST
S (CNT,ORLST)=0
F S ORLST=$O(ORLST(ORLST)) Q:'ORLST D
.S ORD=+ORLST(ORLST)
.S X=$G(^OR(100,ORD,0))
.Q:+$P(X,U,2)'=DFN
.S ORL=+$P(X,U,10),PKG=$$GET1^DIQ(9.4,+$P(X,U,14),1),LP=0
.F S LP=$O(^OR(100,ORD,4.5,LP)) Q:'LP S Y=$G(^(LP,0)) D
..N TMP,OIL
..S PID=$P(Y,U,4),INST=$P(Y,U,3)
..I PID'="ORDERABLE",PID'="ADDITIVE" Q
..S ITM=+$G(^OR(100,ORD,4.5,LP,1))
..I PKG="LR" S ITM=ITM_U_PKG_U_$$VALUE^ORCSAVE2(ORD,"SPECIMEN",INST)
..E I PKG="PSIV" S ITM=ITM_U_PKG_U_$S(PID="ADDITIVE":"A",1:"B;"_$$VALUE^ORCSAVE2(ORD,"VOLUME",INST))
..E I $E(PKG,1,2)="PS" S ITM=ITM_U_PKG_U_$$VALUE^ORCSAVE2(ORD,"DRUG",INST)
..S OIL(1)=ITM
..D ACCEPT(.TMP,DFN,PKG,"",ORL,.OIL,ORD)
..I $D(TMP)>1 S CNT=CNT+1 M LST(CNT)=TMP
Q
ACCEPT(LST,DFN,FID,STRT,ORL,OIL,ORIFN) ; Return list of Order Checks on Accept Order
; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo
N X,Y,USID,ORCHECK,ORI,ORX,ORY
; convert relative start date to real start date
S ORL=ORL_";SC(",X=STRT,STRT=""
D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2
I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y
; do the SELECT order checks
S ORI=0 F S ORI=$O(OIL(ORI)) Q:'ORI D
. S USID=$$USID(OIL(ORI))
. S OIL(ORI,"USID")=USID
. S ORX=1,ORX(1)=+OIL(ORI)_"|"_FID_"|"_USID
. D EN^ORKCHK(.ORY,DFN,.ORX,"SELECT")
. I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK
. K ORX,ORY
; do the ACCEPT order checks
S (ORI,ORX)=0 F S ORI=$O(OIL(ORI)) Q:'ORI D
. S ORX=ORX+1
. S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_OIL(ORI,"USID")_"|"_STRT
. I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3)
D EN^ORKCHK(.ORY,DFN,.ORX,"ACCEPT")
I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK
; return ORCHECK as 1 dimensional list
D CHK2LST
Q
DELAY(LST,DFN,FID,STRT,ORL,OIL) ; Return list of Order Checks on Accept Delayed
; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo
N X,Y,ORCHECK,ORI,ORX,ORY
; convert relative start date to real start date
S ORL=ORL_";SC(",X=STRT,STRT=""
D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2
I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y
; do the ACCEPT order checks
S (ORI,ORX)=0 F S ORI=$O(OIL(ORI)) Q:'ORI D
. S ORX=ORX+1
. S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_$$USID(OIL(ORI))_"|"_STRT
. I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3)
D EN^ORKCHK(.ORY,DFN,.ORX,"ALL")
I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK
; return ORCHECK as 1 dimensional list
D CHK2LST
Q
SESSION(LST,ORVP,ORLST) ; Return list of Order Checks on Release Order
N ORES,ORCHECK
S ORVP=+ORVP_";DPT("
S I=0 F S I=$O(ORLST(I)) Q:'I D
. I +$P(ORLST(I),";",2)'=1 Q ; order not new
. I $P(ORLST(I),U,3)="0" Q ; order not being released
. S ORES($P(ORLST(I),U))=""
D SESSION^ORCHECK
D CHK2LST
Q
; IHS/MSC/DKM - Added following entry point
MANUAL(LST,ORVP,ORLST) ; Return list of Order Checks on Manual Request
N ORCHECK,ORES,I
S ORVP=+ORVP_";DPT("
S I=0 F S I=$O(ORLST(I)) Q:'I D
. S ORES(ORLST(I))=""
D MANUAL^ORCHECK
D CHK2LST
Q
SAVECHK(OK,ORVP,RSN,LST) ; Save order checks for session
N ORCHECK,ORIFN S OK=1
D LST2CHK
I $L(RSN)>0 S ORCHECK("OK")=RSN
S ORIFN=0 F S ORIFN=$O(ORCHECK(ORIFN)) Q:'ORIFN D OC^ORCSAVE2
Q
DELORD(OK,ORIFN) ; Delete order
N STS,DIK,DA
S STS=$P(^OR(100,+ORIFN,8,1,0),U,15),OK=0
I (STS=10)!(STS=11) D Q ; makes sure it's an unreleased order
. S DA=+ORIFN,DIK="^OR(100," Q:'DA
. D ^DIK
. S OK=1
Q
USID(ORITMX) ; Return universal svc ID for an orderable item
; ORITMX = OI^NMSP^PKGINFO
N RSLT,ORDRUG S RSLT=""
I $E($P(ORITMX,U,2),1,2)="PS" D
. I $P(ORITMX,U,2)="PSIV" D
. . N PSOI,TYPE,VOL S VOL=""
. . S PSOI=+$P($G(^ORD(101.43,+ORITMX,0)),U,2)
. . S TYPE=$P($P(ORITMX,U,3),";")
. . I TYPE="B" S VOL=$P($P(ORITMX,U,3),";",2)
. . D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORDRUG)
. . S ORDRUG=+ORDRUG
. E S ORDRUG=+$P(ORITMX,U,3)
. S RSLT=$$ENDCM^PSJORUTL(ORDRUG)
. S RSLT=$P(RSLT,U,3)_"^^99NDF^"_ORDRUG_U_$$NAME50^ORPEAPI(ORDRUG)_"^99PSD"
E S RSLT=$$USID^ORMBLD(+ORITMX)
I +$P(RSLT,U)=0,+($P(RSLT,U,4)=0) S RSLT="" ; has to be null (why?)
Q RSLT
;
CHK2LST ; creates list that can be passed to broker from ORCHECK array
; expects ORCHECK to be present and populates LST
N ORIFN,ORID,CDL,I,ILST S ILST=1 ;Start array at 1 always leaving room for RDI msg at top
S ORIFN="" F S ORIFN=$O(ORCHECK(ORIFN)) Q:ORIFN="" D
. S CDL=0 F S CDL=$O(ORCHECK(ORIFN,CDL)) Q:'CDL D
. . S I=0 F S I=$O(ORCHECK(ORIFN,CDL,I)) Q:'I D
. . . S ORID=ORIFN I +ORID,(+ORID=ORID) S ORID=ORID_";1"
. . . I '$P(ORCHECK(ORIFN,CDL,I),U,2) Q ; CDL="" means don't show
. . . I $P(ORCHECK(ORIFN,CDL,I),U,1)=99 S LST(1)=ORID_U_ORCHECK(ORIFN,CDL,I) Q ;Put RDI warning at the top
. . . S ILST=ILST+1,LST(ILST)=ORID_U_ORCHECK(ORIFN,CDL,I)
Q
LST2CHK ; create ORCHECK array from list passed by broker
N ORIFN,CDL,I,ILST S I=0
S ILST=0 F S ILST=$O(LST(ILST)) Q:'ILST D
. S X=LST(ILST)
. S ORIFN=$P(X,U),CDL=$P(X,U,3)
. I +$G(ORIFN)>0,+$G(CDL)>0 D ;cla 12/16/03
. . S I=I+1,ORCHECK(+ORIFN,CDL,I)=$P(X,U,2,4)
Q
ORWDXC ; SLC/KCM - Utilities for Order Checking;23-Nov-2011 11:50;PLS
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,141,1005,221,243,1010**;Dec 17, 1997;Build 47
+2 ; Modified - IHS/MSC/DKM - Added RENEW and MANUAL EP
ON(VAL) ; returns E if order checking enabled, otherwise D
+1 SET VAL=$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")
+2 QUIT
FILLID(VAL,DLG) ; Return the FillerID (namespace) for a dialog
+1 NEW DGRP
+2 SET VAL=""
SET DGRP=$PIECE($GET(^ORD(101.41,DLG,0)),U,5)
IF 'DGRP
QUIT
+3 SET DLG=$$DEFDLG^ORWDXQ(DGRP)
+4 SET VAL=$PIECE($GET(^ORD(101.41,DLG,0)),U,7)
SET VAL=$$NMSP^ORCD(VAL)
+5 IF VAL="PS"
Begin DoDot:1
+6 NEW X
+7 SET X=$PIECE($PIECE($GET(^ORD(100.98,DGRP,0)),U,3)," ")
+8 IF $LENGTH(X)
SET VAL="PS"_$SELECT(X="UD":"I",1:X)
End DoDot:1
+9 QUIT
DISPLAY(LST,DFN,FID) ; Return list of Order Checks for a FillerID (namespace)
+1 NEW I,ORX,ORY
+2 SET ORX=1
SET ORX(1)="|"_FID
+3 DO EN^ORKCHK(.ORY,DFN,.ORX,"DISPLAY")
+4 SET I=0
FOR
SET I=$ORDER(ORY(I))
IF I'>0
QUIT
SET LST(I)=$PIECE(ORY(I),U,4)
+5 QUIT
+6 ; IHS/MSC/DKM - Added RENEW entry point
RENEW(LST,DFN,ORLST) ;
+1 NEW X,Y,ORL,ORD,PID,INST,ITM,PKG,LP,CNT
+2 IF $DATA(ORLST)=1
SET ORLST(1)=ORLST
+3 SET (CNT,ORLST)=0
+4 FOR
SET ORLST=$ORDER(ORLST(ORLST))
IF 'ORLST
QUIT
Begin DoDot:1
+5 SET ORD=+ORLST(ORLST)
+6 SET X=$GET(^OR(100,ORD,0))
+7 IF +$PIECE(X,U,2)'=DFN
QUIT
+8 SET ORL=+$PIECE(X,U,10)
SET PKG=$$GET1^DIQ(9.4,+$PIECE(X,U,14),1)
SET LP=0
+9 FOR
SET LP=$ORDER(^OR(100,ORD,4.5,LP))
IF 'LP
QUIT
SET Y=$GET(^(LP,0))
Begin DoDot:2
+10 NEW TMP,OIL
+11 SET PID=$PIECE(Y,U,4)
SET INST=$PIECE(Y,U,3)
+12 IF PID'="ORDERABLE"
IF PID'="ADDITIVE"
QUIT
+13 SET ITM=+$GET(^OR(100,ORD,4.5,LP,1))
+14 IF PKG="LR"
SET ITM=ITM_U_PKG_U_$$VALUE^ORCSAVE2(ORD,"SPECIMEN",INST)
+15 IF '$TEST
IF PKG="PSIV"
SET ITM=ITM_U_PKG_U_$SELECT(PID="ADDITIVE":"A",1:"B;"_$$VALUE^ORCSAVE2(ORD,"VOLUME",INST))
+16 IF '$TEST
IF $EXTRACT(PKG,1,2)="PS"
SET ITM=ITM_U_PKG_U_$$VALUE^ORCSAVE2(ORD,"DRUG",INST)
+17 SET OIL(1)=ITM
+18 DO ACCEPT(.TMP,DFN,PKG,"",ORL,.OIL,ORD)
+19 IF $DATA(TMP)>1
SET CNT=CNT+1
MERGE LST(CNT)=TMP
End DoDot:2
End DoDot:1
+20 QUIT
ACCEPT(LST,DFN,FID,STRT,ORL,OIL,ORIFN) ; Return list of Order Checks on Accept Order
+1 ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo
+2 NEW X,Y,USID,ORCHECK,ORI,ORX,ORY
+3 ; convert relative start date to real start date
+4 SET ORL=ORL_";SC("
SET X=STRT
SET STRT=""
+5 IF X="AM"
DO AM^ORCSAVE2
IF X="NEXT"
DO NEXT^ORCSAVE2
+6 IF $LENGTH(X)
SET %DT="FTX"
DO ^%DT
IF Y'>0
SET Y=""
SET STRT=Y
+7 ; do the SELECT order checks
+8 SET ORI=0
FOR
SET ORI=$ORDER(OIL(ORI))
IF 'ORI
QUIT
Begin DoDot:1
+9 SET USID=$$USID(OIL(ORI))
+10 SET OIL(ORI,"USID")=USID
+11 SET ORX=1
SET ORX(1)=+OIL(ORI)_"|"_FID_"|"_USID
+12 DO EN^ORKCHK(.ORY,DFN,.ORX,"SELECT")
+13 ; expects ORY, ORCHECK
IF $DATA(ORY)
DO RETURN^ORCHECK
+14 KILL ORX,ORY
End DoDot:1
+15 ; do the ACCEPT order checks
+16 SET (ORI,ORX)=0
FOR
SET ORI=$ORDER(OIL(ORI))
IF 'ORI
QUIT
Begin DoDot:1
+17 SET ORX=ORX+1
+18 SET ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_OIL(ORI,"USID")_"|"_STRT
+19 IF $PIECE(OIL(ORI),U,2)="LR"
SET $PIECE(ORX(ORX),"|",6)=$PIECE(OIL(ORI),U,3)
End DoDot:1
+20 DO EN^ORKCHK(.ORY,DFN,.ORX,"ACCEPT")
+21 ; expects ORY, ORCHECK
IF $DATA(ORY)
DO RETURN^ORCHECK
+22 ; return ORCHECK as 1 dimensional list
+23 DO CHK2LST
+24 QUIT
DELAY(LST,DFN,FID,STRT,ORL,OIL) ; Return list of Order Checks on Accept Delayed
+1 ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo
+2 NEW X,Y,ORCHECK,ORI,ORX,ORY
+3 ; convert relative start date to real start date
+4 SET ORL=ORL_";SC("
SET X=STRT
SET STRT=""
+5 IF X="AM"
DO AM^ORCSAVE2
IF X="NEXT"
DO NEXT^ORCSAVE2
+6 IF $LENGTH(X)
SET %DT="FTX"
DO ^%DT
IF Y'>0
SET Y=""
SET STRT=Y
+7 ; do the ACCEPT order checks
+8 SET (ORI,ORX)=0
FOR
SET ORI=$ORDER(OIL(ORI))
IF 'ORI
QUIT
Begin DoDot:1
+9 SET ORX=ORX+1
+10 SET ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_$$USID(OIL(ORI))_"|"_STRT
+11 IF $PIECE(OIL(ORI),U,2)="LR"
SET $PIECE(ORX(ORX),"|",6)=$PIECE(OIL(ORI),U,3)
End DoDot:1
+12 DO EN^ORKCHK(.ORY,DFN,.ORX,"ALL")
+13 ; expects ORY, ORCHECK
IF $DATA(ORY)
DO RETURN^ORCHECK
+14 ; return ORCHECK as 1 dimensional list
+15 DO CHK2LST
+16 QUIT
SESSION(LST,ORVP,ORLST) ; Return list of Order Checks on Release Order
+1 NEW ORES,ORCHECK
+2 SET ORVP=+ORVP_";DPT("
+3 SET I=0
FOR
SET I=$ORDER(ORLST(I))
IF 'I
QUIT
Begin DoDot:1
+4 ; order not new
IF +$PIECE(ORLST(I),";",2)'=1
QUIT
+5 ; order not being released
IF $PIECE(ORLST(I),U,3)="0"
QUIT
+6 SET ORES($PIECE(ORLST(I),U))=""
End DoDot:1
+7 DO SESSION^ORCHECK
+8 DO CHK2LST
+9 QUIT
+10 ; IHS/MSC/DKM - Added following entry point
MANUAL(LST,ORVP,ORLST) ; Return list of Order Checks on Manual Request
+1 NEW ORCHECK,ORES,I
+2 SET ORVP=+ORVP_";DPT("
+3 SET I=0
FOR
SET I=$ORDER(ORLST(I))
IF 'I
QUIT
Begin DoDot:1
+4 SET ORES(ORLST(I))=""
End DoDot:1
+5 DO MANUAL^ORCHECK
+6 DO CHK2LST
+7 QUIT
SAVECHK(OK,ORVP,RSN,LST) ; Save order checks for session
+1 NEW ORCHECK,ORIFN
SET OK=1
+2 DO LST2CHK
+3 IF $LENGTH(RSN)>0
SET ORCHECK("OK")=RSN
+4 SET ORIFN=0
FOR
SET ORIFN=$ORDER(ORCHECK(ORIFN))
IF 'ORIFN
QUIT
DO OC^ORCSAVE2
+5 QUIT
DELORD(OK,ORIFN) ; Delete order
+1 NEW STS,DIK,DA
+2 SET STS=$PIECE(^OR(100,+ORIFN,8,1,0),U,15)
SET OK=0
+3 ; makes sure it's an unreleased order
IF (STS=10)!(STS=11)
Begin DoDot:1
+4 SET DA=+ORIFN
SET DIK="^OR(100,"
IF 'DA
QUIT
+5 DO ^DIK
+6 SET OK=1
End DoDot:1
QUIT
+7 QUIT
USID(ORITMX) ; Return universal svc ID for an orderable item
+1 ; ORITMX = OI^NMSP^PKGINFO
+2 NEW RSLT,ORDRUG
SET RSLT=""
+3 IF $EXTRACT($PIECE(ORITMX,U,2),1,2)="PS"
Begin DoDot:1
+4 IF $PIECE(ORITMX,U,2)="PSIV"
Begin DoDot:2
+5 NEW PSOI,TYPE,VOL
SET VOL=""
+6 SET PSOI=+$PIECE($GET(^ORD(101.43,+ORITMX,0)),U,2)
+7 SET TYPE=$PIECE($PIECE(ORITMX,U,3),";")
+8 IF TYPE="B"
SET VOL=$PIECE($PIECE(ORITMX,U,3),";",2)
+9 DO ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORDRUG)
+10 SET ORDRUG=+ORDRUG
End DoDot:2
+11 IF '$TEST
SET ORDRUG=+$PIECE(ORITMX,U,3)
+12 SET RSLT=$$ENDCM^PSJORUTL(ORDRUG)
+13 SET RSLT=$PIECE(RSLT,U,3)_"^^99NDF^"_ORDRUG_U_$$NAME50^ORPEAPI(ORDRUG)_"^99PSD"
End DoDot:1
+14 IF '$TEST
SET RSLT=$$USID^ORMBLD(+ORITMX)
+15 ; has to be null (why?)
IF +$PIECE(RSLT,U)=0
IF +($PIECE(RSLT,U,4)=0)
SET RSLT=""
+16 QUIT RSLT
+17 ;
CHK2LST ; creates list that can be passed to broker from ORCHECK array
+1 ; expects ORCHECK to be present and populates LST
+2 ;Start array at 1 always leaving room for RDI msg at top
NEW ORIFN,ORID,CDL,I,ILST
SET ILST=1
+3 SET ORIFN=""
FOR
SET ORIFN=$ORDER(ORCHECK(ORIFN))
IF ORIFN=""
QUIT
Begin DoDot:1
+4 SET CDL=0
FOR
SET CDL=$ORDER(ORCHECK(ORIFN,CDL))
IF 'CDL
QUIT
Begin DoDot:2
+5 SET I=0
FOR
SET I=$ORDER(ORCHECK(ORIFN,CDL,I))
IF 'I
QUIT
Begin DoDot:3
+6 SET ORID=ORIFN
IF +ORID
IF (+ORID=ORID)
SET ORID=ORID_";1"
+7 ; CDL="" means don't show
IF '$PIECE(ORCHECK(ORIFN,CDL,I),U,2)
QUIT
+8 ;Put RDI warning at the top
IF $PIECE(ORCHECK(ORIFN,CDL,I),U,1)=99
SET LST(1)=ORID_U_ORCHECK(ORIFN,CDL,I)
QUIT
+9 SET ILST=ILST+1
SET LST(ILST)=ORID_U_ORCHECK(ORIFN,CDL,I)
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
LST2CHK ; create ORCHECK array from list passed by broker
+1 NEW ORIFN,CDL,I,ILST
SET I=0
+2 SET ILST=0
FOR
SET ILST=$ORDER(LST(ILST))
IF 'ILST
QUIT
Begin DoDot:1
+3 SET X=LST(ILST)
+4 SET ORIFN=$PIECE(X,U)
SET CDL=$PIECE(X,U,3)
+5 ;cla 12/16/03
IF +$GET(ORIFN)>0
IF +$GET(CDL)>0
Begin DoDot:2
+6 SET I=I+1
SET ORCHECK(+ORIFN,CDL,I)=$PIECE(X,U,2,4)
End DoDot:2
End DoDot:1
+7 QUIT
