- Timestamp:
- Dec 4, 2009, 12:11:15 AM (15 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXC.m
r613 r623 1 ORWDXC ; SLC/KCM - Utilities for Order Checking 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,141,221,243**;Dec 17, 1997;Build 242 3 ; 4 ON(VAL) ; returns E if order checking enabled, otherwise D 5 S VAL=$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE") 6 Q 7 FILLID(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 17 DISPLAY(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 23 ACCEPT(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 48 DELAY(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 65 SESSION(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 75 SAVECHK(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 81 DELORD(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 89 USID(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_$$NAME50^ORPEAPI(ORDRUG)_"^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 ; 107 CHK2LST ; 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=1 ;Start array at 1 always leaving room for RDI msg at top 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 . . . 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 116 . . . S ILST=ILST+1,LST(ILST)=ORID_U_ORCHECK(ORIFN,CDL,I) 117 Q 118 LST2CHK ; create ORCHECK array from list passed by broker 119 N ORIFN,CDL,I,ILST S I=0 120 S ILST=0 F S ILST=$O(LST(ILST)) Q:'ILST D 121 . S X=LST(ILST) 122 . S ORIFN=$P(X,U),CDL=$P(X,U,3) 123 . I +$G(ORIFN)>0,+$G(CDL)>0 D ;cla 12/16/03 124 . . S I=I+1,ORCHECK(+ORIFN,CDL,I)=$P(X,U,2,4) 125 Q 1 ORWDXC ; SLC/KCM - Utilities for Order Checking 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,141,221**;Dec 17, 1997 3 ; 4 ON(VAL) ; returns E if order checking enabled, otherwise D 5 S VAL=$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE") 6 Q 7 FILLID(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 17 DISPLAY(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 23 ACCEPT(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 48 DELAY(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 65 SESSION(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 75 SAVECHK(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 81 DELORD(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 89 USID(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 ; 107 CHK2LST ; 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 117 LST2CHK ; 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 TracChangeset
for help on using the changeset viewer.
