source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXC.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.5 KB
Line 
1ORWDXC ; SLC/KCM - Utilities for Order Checking
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,141,221**;Dec 17, 1997
3 ;
4ON(VAL) ; returns E if order checking enabled, otherwise D
5 S VAL=$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")
6 Q
7FILLID(VAL,DLG) ; Return the FillerID (namespace) for a dialog
8 N DGRP
9 S VAL="",DGRP=$P($G(^ORD(101.41,DLG,0)),U,5) Q:'DGRP
10 S DLG=$$DEFDLG^ORWDXQ(DGRP)
11 S VAL=$P($G(^ORD(101.41,DLG,0)),U,7),VAL=$$NMSP^ORCD(VAL)
12 I VAL="PS" D
13 . N X
14 . S X=$P($P($G(^ORD(100.98,DGRP,0)),U,3)," ")
15 . I $L(X) S VAL="PS"_$S(X="UD":"I",1:X)
16 Q
17DISPLAY(LST,DFN,FID) ; Return list of Order Checks for a FillerID (namespace)
18 N I,ORX,ORY
19 S ORX=1,ORX(1)="|"_FID
20 D EN^ORKCHK(.ORY,DFN,.ORX,"DISPLAY")
21 S I=0 F S I=$O(ORY(I)) Q:I'>0 S LST(I)=$P(ORY(I),U,4)
22 Q
23ACCEPT(LST,DFN,FID,STRT,ORL,OIL,ORIFN) ; Return list of Order Checks on Accept Order
24 ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo
25 N X,Y,USID,ORCHECK,ORI,ORX,ORY
26 ; convert relative start date to real start date
27 S ORL=ORL_";SC(",X=STRT,STRT=""
28 D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2
29 I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y
30 ; do the SELECT order checks
31 S ORI=0 F S ORI=$O(OIL(ORI)) Q:'ORI D
32 . S USID=$$USID(OIL(ORI))
33 . S OIL(ORI,"USID")=USID
34 . S ORX=1,ORX(1)=+OIL(ORI)_"|"_FID_"|"_USID
35 . D EN^ORKCHK(.ORY,DFN,.ORX,"SELECT")
36 . I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK
37 . K ORX,ORY
38 ; do the ACCEPT order checks
39 S (ORI,ORX)=0 F S ORI=$O(OIL(ORI)) Q:'ORI D
40 . S ORX=ORX+1
41 . S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_OIL(ORI,"USID")_"|"_STRT
42 . I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3)
43 D EN^ORKCHK(.ORY,DFN,.ORX,"ACCEPT")
44 I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK
45 ; return ORCHECK as 1 dimensional list
46 D CHK2LST
47 Q
48DELAY(LST,DFN,FID,STRT,ORL,OIL) ; Return list of Order Checks on Accept Delayed
49 ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo
50 N X,Y,ORCHECK,ORI,ORX,ORY
51 ; convert relative start date to real start date
52 S ORL=ORL_";SC(",X=STRT,STRT=""
53 D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2
54 I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y
55 ; do the ACCEPT order checks
56 S (ORI,ORX)=0 F S ORI=$O(OIL(ORI)) Q:'ORI D
57 . S ORX=ORX+1
58 . S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_$$USID(OIL(ORI))_"|"_STRT
59 . I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3)
60 D EN^ORKCHK(.ORY,DFN,.ORX,"ALL")
61 I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK
62 ; return ORCHECK as 1 dimensional list
63 D CHK2LST
64 Q
65SESSION(LST,ORVP,ORLST) ; Return list of Order Checks on Release Order
66 N ORES,ORCHECK
67 S ORVP=+ORVP_";DPT("
68 S I=0 F S I=$O(ORLST(I)) Q:'I D
69 . I +$P(ORLST(I),";",2)'=1 Q ; order not new
70 . I $P(ORLST(I),U,3)="0" Q ; order not being released
71 . S ORES($P(ORLST(I),U))=""
72 D SESSION^ORCHECK
73 D CHK2LST
74 Q
75SAVECHK(OK,ORVP,RSN,LST) ; Save order checks for session
76 N ORCHECK,ORIFN S OK=1
77 D LST2CHK
78 I $L(RSN)>0 S ORCHECK("OK")=RSN
79 S ORIFN=0 F S ORIFN=$O(ORCHECK(ORIFN)) Q:'ORIFN D OC^ORCSAVE2
80 Q
81DELORD(OK,ORIFN) ; Delete order
82 N STS,DIK,DA
83 S STS=$P(^OR(100,+ORIFN,8,1,0),U,15),OK=0
84 I (STS=10)!(STS=11) D Q ; makes sure it's an unreleased order
85 . S DA=+ORIFN,DIK="^OR(100," Q:'DA
86 . D ^DIK
87 . S OK=1
88 Q
89USID(ORITMX) ; Return universal svc ID for an orderable item
90 ; ORITMX = OI^NMSP^PKGINFO
91 N RSLT,ORDRUG S RSLT=""
92 I $E($P(ORITMX,U,2),1,2)="PS" D
93 . I $P(ORITMX,U,2)="PSIV" D
94 . . N PSOI,TYPE,VOL S VOL=""
95 . . S PSOI=+$P($G(^ORD(101.43,+ORITMX,0)),U,2)
96 . . S TYPE=$P($P(ORITMX,U,3),";")
97 . . I TYPE="B" S VOL=$P($P(ORITMX,U,3),";",2)
98 . . D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORDRUG)
99 . . S ORDRUG=+ORDRUG
100 . E S ORDRUG=+$P(ORITMX,U,3)
101 . S RSLT=$$ENDCM^PSJORUTL(ORDRUG)
102 . S RSLT=$P(RSLT,U,3)_"^^99NDF^"_ORDRUG_U_$P($G(^PSDRUG(ORDRUG,0)),U)_"^99PSD"
103 E S RSLT=$$USID^ORMBLD(+ORITMX)
104 I +$P(RSLT,U)=0,+($P(RSLT,U,4)=0) S RSLT="" ; has to be null (why?)
105 Q RSLT
106 ;
107CHK2LST ; creates list that can be passed to broker from ORCHECK array
108 ; expects ORCHECK to be present and populates LST
109 N ORIFN,ORID,CDL,I,ILST S ILST=0
110 S ORIFN="" F S ORIFN=$O(ORCHECK(ORIFN)) Q:ORIFN="" D
111 . S CDL=0 F S CDL=$O(ORCHECK(ORIFN,CDL)) Q:'CDL D
112 . . S I=0 F S I=$O(ORCHECK(ORIFN,CDL,I)) Q:'I D
113 . . . S ORID=ORIFN I +ORID,(+ORID=ORID) S ORID=ORID_";1"
114 . . . I '$P(ORCHECK(ORIFN,CDL,I),U,2) Q ; CDL="" means don't show
115 . . . S ILST=ILST+1,LST(ILST)=ORID_U_ORCHECK(ORIFN,CDL,I)
116 Q
117LST2CHK ; create ORCHECK array from list passed by broker
118 N ORIFN,CDL,I,ILST S I=0
119 S ILST=0 F S ILST=$O(LST(ILST)) Q:'ILST D
120 . S X=LST(ILST)
121 . S ORIFN=$P(X,U),CDL=$P(X,U,3)
122 . I +$G(ORIFN)>0,+$G(CDL)>0 D ;cla 12/16/03
123 . . S I=I+1,ORCHECK(+ORIFN,CDL,I)=$P(X,U,2,4)
124 Q
Note: See TracBrowser for help on using the repository browser.