Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORWDXC

ORWDXC.m

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