- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE.m
r613 r623 1 ORCSAVE ;SLC/MKB/JDL-Save ; 7/24/07 9:54am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,73,92,94,116,141,163,187,190,195,243**;Dec 17, 1997;Build 242 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 NEW(ORDIALOG,ORDG,ORPKG,ORCAT,OREVENT,ORDUZ,ORLOG) ; -- New order 5 ; Returns ORIFN = [new] order number, if created/saved 6 D EN 7 Q 8 ; 9 XX ; -- save new/unreleased edited order into Orders file 10 ; Requires: ORDIALOG() = array of dialog values 11 ; ORIFN = IFN of original order that was edited 12 ; 13 N OLDIFN S ORIFN=+ORIFN,OLDIFN=0 14 I $S($P(^OR(100,ORIFN,3),U,3)=11:0,$P(^(3),U,3)'=10:1,$P(^(8,1,0),U,4)=2:0,1:1) S OLDIFN=ORIFN K ORIFN ; create new order if released or delayed&signed 15 D EN Q:'ORIFN S:'$G(ORDA) ORDA=1 16 I $G(OLDIFN) D ;save links between orders 17 . S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=1 18 . S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5) 19 I $D(^OR(100,+OLDIFN,0)) D 20 . Q:'$G(OREVTDF) 21 . N OLDEVT,OLDSTS,LSTACT,PATID,NOW,WHEN 22 . S (OLDEVT,OLDSTS,LSTACT)=0 23 . S NOW=$$NOW^XLFDT 24 . S OLDEVT=$P(^(0),U,17),OLDSTS=$P(^(3),U,3) 25 . ; Active status = 6 from #100.01 26 . I (OLDEVT>0),OLDSTS=6 D 27 . . S $P(^OR(100,+ORIFN,0),U,17)=OLDEVT 28 . . S $P(^OR(100,+ORIFN,3),U,3)=11 29 . . S LSTACT=$P($G(^OR(100,+ORIFN,3)),U,7) 30 . . I $D(^OR(100,+ORIFN,8,LSTACT,0)) D 31 . . . S $P(^OR(100,+ORIFN,8,LSTACT,0),U,15)=11 32 . . . S PATID=$P(^OR(100,+ORIFN,0),U,2) 33 . . . S WHEN=$P(^OR(100,+ORIFN,8,LSTACT,0),U) 34 . . . S ^OR(100,"AC",PATID,9999999-WHEN,+ORIFN,LSTACT)="" 35 Q 36 ; 37 RN ; -- save new/unreleased renewal order into Orders file 38 ; Requires: ORDIALOG() = array of new dialog values 39 ; ORIFN = IFN of original order that was renewed 40 ; 41 N OLDIFN S OLDIFN=+ORIFN K ORIFN 42 D EN Q:'ORIFN S:'$G(ORDA) ORDA=1 43 S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=2 44 S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5) 45 Q 46 ; 47 EN ; -- save new/unreleased order in ORDIALOG() into Orders file 48 ; Requires: ORVP, ORNP [and ORL, ORTS, ORAPPT if available] 49 ; If defined: ORCAT,ORPKG,ORDG,ORLOG,ORDUZ,OREVENT,ORDCNTRL,ORSRC 50 ; (else use values from ORDIALOG and current state) 51 ; 52 N PKG,NOW,NODE,CNT,CDL,I,X,STS,SIGNREQD,LOC,TRSPEC,NATR,CATG,DG,LOG,USR,TYPE 53 Q:'$G(ORVP) Q:'$G(ORDIALOG) Q:'$D(^ORD(101.41,+ORDIALOG,0)) 54 S NOW=$$NOW^XLFDT,SIGNREQD=+$P(^ORD(101.41,+ORDIALOG,0),U,6) 55 S CATG=$S($L($G(ORCAT)):ORCAT,1:$S($$INPT^ORCD:"I",1:"O")) 56 S PKG=$S($G(ORPKG):ORPKG,1:$P(^ORD(101.41,+ORDIALOG,0),U,7)) 57 I $G(ORIFN),$D(^OR(100,ORIFN,0)) S STS=$P(^(3),U,3) G EN2 ; unrel order 58 S DG=$S($G(ORDG):+ORDG,1:$P(^ORD(101.41,+ORDIALOG,0),U,5)) 59 I $G(OREVENT),$$GET1^DIQ(9.4,+PKG_",",1)'="PSO",'$G(DGPMT) S LOC="",TRSPEC="" ;195 60 E S LOC=$G(ORL),TRSPEC=$G(ORTS) 61 S TYPE=$S("^B^C^X^P^0^"[(U_$G(ORSRC)_U):ORSRC,$G(ORDCNTRL)="SN":"P",1:0) 62 S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ) 63 S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed 64 S STS=$S($G(OREVENT):10,1:11),ORIFN=$$NEXTIFN Q:'ORIFN 65 EN1 S ^OR(100,ORIFN,0)=ORIFN_U_ORVP_U_U_$G(ORNP)_U_+ORDIALOG_";ORD(101.41,^"_USR_U_LOG_U_U_U_LOC_U_DG_U_CATG_U_TRSPEC_U_PKG_U_U_SIGNREQD_U_$G(OREVENT)_U_$G(ORAPPT) 66 S ^OR(100,ORIFN,3)=LOG_"^90^"_STS_U_$S($G(ORIT):ORIT_";ORD(101.41,",1:"")_U_$G(ORDIALOG("PREV"))_"^^1^^^^"_TYPE 67 S ^OR(100,ORIFN,8,0)="^100.008DA^1^1",^OR(100,ORIFN,8,1,0)=LOG_"^NW^"_$G(ORNP)_U_$S(SIGNREQD:2,1:3)_"^^^^^^^^"_NATR_U_USR_"^1^"_STS,^OR(100,ORIFN,8,"C","NW",1)="" 68 S ^OR(100,"AF",LOG,ORIFN,1)="" 69 S ^OR(100,"ACT",ORVP,9999999-LOG,+DG,ORIFN,1)="" 70 S:STS'=10 ^OR(100,"AC",ORVP,9999999-LOG,ORIFN,1)="" 71 S:SIGNREQD ^OR(100,"AS",ORVP,9999999-LOG,ORIFN,1)="" 72 S:$G(OREVENT) ^OR(100,"AEVNT",ORVP,OREVENT,ORIFN)="" 73 EN2 S ORIFN=+ORIFN D RESPONSE ; save responses 74 I $P(^OR(100,ORIFN,0),"^",5) D ;Copy orders PKI fix 75 . N OI 76 . S OI=+$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,ORIFN,4.5,OI,1)) Q:'OI 77 . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q 78 . D PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q")) 79 . I $E($G(ORY))=2 S ORDEA=ORY 80 K ^OR(100,ORIFN,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFN_";1") ; order text 81 S NODE=$G(^OR(100,ORIFN,0)) D S ^OR(100,ORIFN,0)=NODE 82 . S $P(NODE,U,4)=$G(ORNP) ; COST? 83 . S I=$O(^OR(100,ORIFN,4.5,"ID","LOCATION",0)) 84 . I I,$P(NODE,U,10) S X=+$G(^OR(100,ORIFN,4.5,+I,1)) S:X $P(NODE,U,10)=X_";SC(" ;reset Loc if prev value 85 . S I=$O(^OR(100,ORIFN,4.5,"ID","CLASS",0)) 86 . I I S X=$G(^OR(100,ORIFN,4.5,+I,1)) S:"^I^O^"[(U_X_U) $P(NODE,U,12)=X 87 S $P(^OR(100,ORIFN,3),U)=NOW 88 K ^OR(100,ORIFN,9) I $G(ORCHECK) D ; save order checks 89 . S (CNT,CDL)=0 F S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL'>0 S I=0 D 90 . . F S I=$O(ORCHECK("NEW",CDL,I)) Q:I'>0 S X=ORCHECK("NEW",CDL,I) D 91 . . . S CNT=CNT+1,^OR(100,ORIFN,9,"B",+X,CNT)="" 92 . . . S ^OR(100,ORIFN,9,CNT,0)=$P(X,U,1,2),^(1)=$E($P(X,U,3),1,245) 93 . S:CNT ^OR(100,ORIFN,9,0)="^100.09PA^"_CNT_U_CNT 94 K ORDEA 95 ENQ Q 96 ; 97 NEXTIFN() ; -- Returns next available ORIFN 98 N I,HDR,LAST,TOTAL,DA 99 F I=1:1:10 L +^OR(100,0):1 Q:$T H 2 100 I '$T Q "^" 101 S HDR=$G(^OR(100,0)),TOTAL=+$P(HDR,U,4),LAST=$O(^OR(100,"?"),-1) 102 S I=LAST\1 F I=(I+1):1 Q:'$D(^OR(100,I,0)) 103 S DA=I,^OR(100,DA,0)=DA,$P(HDR,U,3,4)=DA_U_(TOTAL+1) 104 S ^OR(100,0)=HDR L -^OR(100,0) 105 Q DA 106 ; 107 RESPONSE ; -- Save responses in ORDIALOG() into ^OR(100,ORIFN,4.5) 108 N PROMPT,CNT,ITM,TYPE,INST,VALUE,I,START,PAT,X 109 S PAT=$P(^OR(100,ORIFN,0),U,2),START=$P(^(0),U,8) K ^(4.5) 110 S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D 111 . S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM 112 . S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE) 113 . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D 114 . . S VALUE=$G(ORDIALOG(PROMPT,INST)) Q:VALUE="" S CNT=CNT+1 115 . . S ^OR(100,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2) 116 . . S:$L($P(ITM,U,2)) ^OR(100,ORIFN,4.5,"ID",$P(ITM,U,2),CNT)="" 117 . . I VALUE<1,TYPE="N" S VALUE=0_+VALUE I VALUE="00" S VALUE=0 118 . . S:TYPE'="W" ^OR(100,ORIFN,4.5,CNT,1)=VALUE 119 . . M:TYPE="W" ^OR(100,ORIFN,4.5,CNT,2)=@VALUE ; array root 120 S ^OR(100,ORIFN,4.5,0)="^100.045A^"_CNT_U_CNT 121 R1 ; [Reset] Orderables 122 I $D(^OR(100,ORIFN,.1)) S I=0 F S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0 S X=$G(^(I,0)) I X,PAT,START K ^OR(100,"AOI",X,PAT,9999999-START,ORIFN) ; kill xref 123 K ^OR(100,ORIFN,.1) I $D(^OR(100,ORIFN,4.5,"ID","ORDERABLE")) D 124 . S (I,CNT)=0 125 . F S I=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D 126 . . S X=$G(^OR(100,ORIFN,4.5,I,1)) Q:'X 127 . . S CNT=CNT+1,^OR(100,ORIFN,.1,CNT,0)=X,^OR(100,ORIFN,.1,"B",X,CNT)="" 128 . . I PAT,START S ^OR(100,"AOI",X,PAT,9999999-START,ORIFN)="" 129 . S ^OR(100,ORIFN,.1,0)="^100.001PA^"_CNT_U_CNT 130 Q 131 ; 132 RESUME(IFN) ; -- add Response nodes for RESUME tray service 133 ; S ^OR(100,+IFN,4.5,<next>,0)=DT_"^^^RESUME",^(1)=1 134 ; 135 N X,Y,DA,DIC 136 S DIC="^OR(100,"_+IFN_",4.5,",DIC(0)="LX",DA(1)=+IFN,X=DT 137 S DIC("DR")=".04///RESUME",DIC("P")=$P(^DD(100,4.5,0),U,2) 138 D ^DIC S:Y ^OR(100,+IFN,4.5,+Y,1)=1 139 Q 140 ; 141 PROVIDER(ORDER,PROV) ; -- Change PROVider assigned to ORDER 142 Q:'$G(ORDER) Q:'$G(PROV) 143 N ORACT S ORACT=+$P(ORDER,";",2) S:'ORACT ORACT=1 144 S $P(^OR(100,+ORDER,8,ORACT,0),U,3)=PROV 145 S:ORACT=1 $P(^OR(100,+ORDER,0),U,4)=PROV 146 Q 147 ; 148 ACTION(CODE,DA,PROV,REASON,WHEN,WHO) ; -- save new action 149 N NEXT,TOTAL,HDR,LAST,X,PAT,DGRP,SIG,NATR,TXT S DA=+DA 150 Q:'$D(^OR(100,DA,0)) 0 Q:$G(CODE)'?2U 0 151 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ 152 S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed 153 S PAT=$P(^OR(100,DA,0),U,2),DGRP=$P(^(0),U,11),SIG=$P(^(0),U,16),X=+$P($G(^(3)),U,7),HDR=$G(^(8,0)) 154 S:X'>0 X=1 S TXT=$P($G(^OR(100,DA,8,X,0)),U,14) ;current actn's txt ptr 155 S:HDR="" HDR="^100.008DA^^" S TOTAL=+$P(HDR,U,4) 156 S LAST=$O(^OR(100,DA,8,"C",CODE,"?"),-1) I LAST D 157 . S X=$G(^OR(100,DA,8,LAST,0)) Q:$P(X,U,15)'=11 Q:$P(X,U,4)'=2 158 . S NEXT=LAST I PAT,$P(X,U) D ; kill old xref entries 159 . . K:DGRP ^OR(100,"ACT",PAT,(9999999-$P(X,U)),DGRP,DA,NEXT) 160 . . K ^OR(100,"AC",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AS",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AF",$P(X,U),DA,NEXT) 161 S:'$G(NEXT) NEXT=$O(^OR(100,DA,8,"?"),-1)+1,TOTAL=TOTAL+1 162 S ^OR(100,DA,8,NEXT,0)=WHEN_U_CODE_U_$G(PROV)_U_$S(SIG:2,1:3)_"^^^^^^^^"_NATR_U_WHO_U_TXT_"^11",^OR(100,DA,8,"C",CODE,NEXT)="" 163 S ^OR(100,"AF",WHEN,DA,NEXT)="" 164 I PAT,DGRP S ^OR(100,"ACT",PAT,9999999-WHEN,DGRP,DA,NEXT)="" 165 I PAT S ^OR(100,"AC",PAT,9999999-WHEN,DA,NEXT)="" 166 I SIG S ^OR(100,"AS",PAT,9999999-WHEN,DA,NEXT)="" 167 S:$L($G(REASON)) ^OR(100,DA,8,NEXT,1)=REASON 168 S $P(HDR,U,3,4)=NEXT_U_TOTAL,^OR(100,DA,8,0)=HDR 169 Q NEXT 170 ; 171 SET(DLG) ; -- Create new parent for order set ORDIALOG 172 ; Returns ORPIFN = ifn of new parent order for set 173 ; 174 Q:'$G(ORVP) Q:'$G(DLG) N OR0,PKG,NOW,CATG,STS,ORLOC,TRSPEC,X 175 S OR0=$G(^ORD(101.41,DLG,0)) Q:OR0="" S ORPIFN=$$NEXTIFN Q:'ORPIFN 176 S PKG=$O(^DIC(9.4,"C","OR",0)),CATG=$S($$INPT^ORCD:"I",1:"O"),STS=$S($G(OREVENT):10,1:11),NOW=$S($G(ORSLOG):ORSLOG,1:+$E($$NOW^XLFDT,1,12)) 177 I $G(OREVENT) S ORLOC="",TRSPEC="" 178 S ^OR(100,ORPIFN,0)=ORPIFN_U_ORVP_U_U_$G(ORNP)_U_DLG_";ORD(101.41,^"_DUZ_U_NOW_U_U_U_ORLOC_U_U_CATG_U_TRSPEC_U_PKG_"^^^"_$G(OREVENT),^(3)=NOW_"^90^"_STS_U_$S($G(ORIT):ORIT_"ORD(101.41,",1:"")_"^^^1^^^^0^^"_+$P(OR0,U,6) 179 S ^OR(100,ORPIFN,8,0)="^100.008DA^1^1",^(1,0)=NOW_"^NW^"_$G(ORNP)_"^^^^^^^^^^"_DUZ_"^^"_STS,^OR(100,ORPIFN,8,"C","NW",1)="",^OR(100,"AF",NOW,ORPIFN,1)="" 180 S ^OR(100,"ACT",ORVP,9999999-NOW,ORPIFN,1)="" 181 S:STS=11 ^OR(100,"AC",ORVP,9999999-NOW,ORPIFN,1)="" 182 ; AEVNT ?? 183 S ^OR(100,ORPIFN,1,0)="^100.011^1^1",^(1,0)=$P(OR0,U,2) ; Order text 184 Q 1 ORCSAVE ;SLC/MKB/JDL-Save ;9/13/04 14:05 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,73,92,94,116,141,163,187,190,195**;Dec 17, 1997 3 NEW(ORDIALOG,ORDG,ORPKG,ORCAT,OREVENT,ORDUZ,ORLOG) ; -- New order 4 ; Returns ORIFN = [new] order number, if created/saved 5 D EN 6 Q 7 ; 8 XX ; -- save new/unreleased edited order into Orders file 9 ; Requires: ORDIALOG() = array of dialog values 10 ; ORIFN = IFN of original order that was edited 11 ; 12 N OLDIFN S ORIFN=+ORIFN,OLDIFN=0 13 I $S($P(^OR(100,ORIFN,3),U,3)=11:0,$P(^(3),U,3)'=10:1,$P(^(8,1,0),U,4)=2:0,1:1) S OLDIFN=ORIFN K ORIFN ; create new order if released or delayed&signed 14 D EN Q:'ORIFN S:'$G(ORDA) ORDA=1 15 I $G(OLDIFN) D ;save links between orders 16 . S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=1 17 . S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5) 18 I $D(^OR(100,+OLDIFN,0)) D 19 . Q:'$G(OREVTDF) 20 . N OLDEVT,OLDSTS,LSTACT,PATID,NOW,WHEN 21 . S (OLDEVT,OLDSTS,LSTACT)=0 22 . S NOW=$$NOW^XLFDT 23 . S OLDEVT=$P(^(0),U,17),OLDSTS=$P(^(3),U,3) 24 . ; Active status = 6 from #100.01 25 . I (OLDEVT>0),OLDSTS=6 D 26 . . S $P(^OR(100,+ORIFN,0),U,17)=OLDEVT 27 . . S $P(^OR(100,+ORIFN,3),U,3)=11 28 . . S LSTACT=$P($G(^OR(100,+ORIFN,3)),U,7) 29 . . I $D(^OR(100,+ORIFN,8,LSTACT,0)) D 30 . . . S $P(^OR(100,+ORIFN,8,LSTACT,0),U,15)=11 31 . . . S PATID=$P(^OR(100,+ORIFN,0),U,2) 32 . . . S WHEN=$P(^OR(100,+ORIFN,8,LSTACT,0),U) 33 . . . S ^OR(100,"AC",PATID,9999999-WHEN,+ORIFN,LSTACT)="" 34 Q 35 ; 36 RN ; -- save new/unreleased renewal order into Orders file 37 ; Requires: ORDIALOG() = array of new dialog values 38 ; ORIFN = IFN of original order that was renewed 39 ; 40 N OLDIFN S OLDIFN=+ORIFN K ORIFN 41 D EN Q:'ORIFN S:'$G(ORDA) ORDA=1 42 S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=2 43 S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5) 44 Q 45 ; 46 EN ; -- save new/unreleased order in ORDIALOG() into Orders file 47 ; Requires: ORVP, ORNP [and ORL, ORTS, ORAPPT if available] 48 ; If defined: ORCAT,ORPKG,ORDG,ORLOG,ORDUZ,OREVENT,ORDCNTRL,ORSRC 49 ; (else use values from ORDIALOG and current state) 50 ; 51 N PKG,NOW,NODE,CNT,CDL,I,X,STS,SIGNREQD,LOC,TRSPEC,NATR,CATG,DG,LOG,USR,TYPE 52 Q:'$G(ORVP) Q:'$G(ORDIALOG) Q:'$D(^ORD(101.41,+ORDIALOG,0)) 53 S NOW=$$NOW^XLFDT,SIGNREQD=+$P(^ORD(101.41,+ORDIALOG,0),U,6) 54 S CATG=$S($L($G(ORCAT)):ORCAT,1:$S($$INPT^ORCD:"I",1:"O")) 55 S PKG=$S($G(ORPKG):ORPKG,1:$P(^ORD(101.41,+ORDIALOG,0),U,7)) 56 I $G(ORIFN),$D(^OR(100,ORIFN,0)) S STS=$P(^(3),U,3) G EN2 ; unrel order 57 S DG=$S($G(ORDG):+ORDG,1:$P(^ORD(101.41,+ORDIALOG,0),U,5)) 58 I $G(OREVENT),$$GET1^DIQ(9.4,+PKG_",",1)'="PSO",'$G(DGPMT) S LOC="",TRSPEC="" ;195 59 E S LOC=$G(ORL),TRSPEC=$G(ORTS) 60 S TYPE=$S("^B^C^X^P^0^"[(U_$G(ORSRC)_U):ORSRC,$G(ORDCNTRL)="SN":"P",1:0) 61 S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ) 62 S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed 63 S STS=$S($G(OREVENT):10,1:11),ORIFN=$$NEXTIFN Q:'ORIFN 64 EN1 S ^OR(100,ORIFN,0)=ORIFN_U_ORVP_U_U_$G(ORNP)_U_+ORDIALOG_";ORD(101.41,^"_USR_U_LOG_U_U_U_LOC_U_DG_U_CATG_U_TRSPEC_U_PKG_U_U_SIGNREQD_U_$G(OREVENT)_U_$G(ORAPPT) 65 S ^OR(100,ORIFN,3)=LOG_"^90^"_STS_U_$S($G(ORIT):ORIT_";ORD(101.41,",1:"")_U_$G(ORDIALOG("PREV"))_"^^1^^^^"_TYPE 66 S ^OR(100,ORIFN,8,0)="^100.008DA^1^1",^OR(100,ORIFN,8,1,0)=LOG_"^NW^"_$G(ORNP)_U_$S(SIGNREQD:2,1:3)_"^^^^^^^^"_NATR_U_USR_"^1^"_STS,^OR(100,ORIFN,8,"C","NW",1)="" 67 S ^OR(100,"AF",LOG,ORIFN,1)="" 68 S ^OR(100,"ACT",ORVP,9999999-LOG,+DG,ORIFN,1)="" 69 S:STS'=10 ^OR(100,"AC",ORVP,9999999-LOG,ORIFN,1)="" 70 S:SIGNREQD ^OR(100,"AS",ORVP,9999999-LOG,ORIFN,1)="" 71 S:$G(OREVENT) ^OR(100,"AEVNT",ORVP,OREVENT,ORIFN)="" 72 EN2 S ORIFN=+ORIFN D RESPONSE ; save responses 73 I $P(^OR(100,ORIFN,0),"^",5) D ;Copy orders PKI fix 74 . N OI 75 . S OI=+$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,ORIFN,4.5,OI,1)) Q:'OI 76 . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q 77 . D PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q")) 78 . I $E($G(ORY))=2 S ORDEA=ORY 79 K ^OR(100,ORIFN,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFN_";1") ; order text 80 S NODE=$G(^OR(100,ORIFN,0)) D S ^OR(100,ORIFN,0)=NODE 81 . S $P(NODE,U,4)=$G(ORNP) ; COST? 82 . S I=$O(^OR(100,ORIFN,4.5,"ID","LOCATION",0)) 83 . I I,$P(NODE,U,10) S X=+$G(^OR(100,ORIFN,4.5,+I,1)) S:X $P(NODE,U,10)=X_";SC(" ;reset Loc if prev value 84 . S I=$O(^OR(100,ORIFN,4.5,"ID","CLASS",0)) 85 . I I S X=$G(^OR(100,ORIFN,4.5,+I,1)) S:"^I^O^"[(U_X_U) $P(NODE,U,12)=X 86 S $P(^OR(100,ORIFN,3),U)=NOW 87 K ^OR(100,ORIFN,9) I $G(ORCHECK) D ; save order checks 88 . S (CNT,CDL)=0 F S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL'>0 S I=0 D 89 . . F S I=$O(ORCHECK("NEW",CDL,I)) Q:I'>0 S X=ORCHECK("NEW",CDL,I) D 90 . . . S CNT=CNT+1,^OR(100,ORIFN,9,"B",+X,CNT)="" 91 . . . S ^OR(100,ORIFN,9,CNT,0)=$P(X,U,1,2),^(1)=$E($P(X,U,3),1,245) 92 . S:CNT ^OR(100,ORIFN,9,0)="^100.09PA^"_CNT_U_CNT 93 K ORDEA 94 ENQ Q 95 ; 96 NEXTIFN() ; -- Returns next available ORIFN 97 N I,HDR,LAST,TOTAL,DA 98 F I=1:1:10 L +^OR(100,0):1 Q:$T H 2 99 I '$T Q "^" 100 S HDR=$G(^OR(100,0)),TOTAL=+$P(HDR,U,4),LAST=$O(^OR(100,"?"),-1) 101 S I=LAST\1 F I=(I+1):1 Q:'$D(^OR(100,I,0)) 102 S DA=I,^OR(100,DA,0)=DA,$P(HDR,U,3,4)=DA_U_(TOTAL+1) 103 S ^OR(100,0)=HDR L -^OR(100,0) 104 Q DA 105 ; 106 RESPONSE ; -- Save responses in ORDIALOG() into ^OR(100,ORIFN,4.5) 107 N PROMPT,CNT,ITM,TYPE,INST,VALUE,I,START,PAT,X 108 S PAT=$P(^OR(100,ORIFN,0),U,2),START=$P(^(0),U,8) K ^(4.5) 109 S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D 110 . S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM 111 . S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE) 112 . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D 113 . . S VALUE=$G(ORDIALOG(PROMPT,INST)) Q:VALUE="" S CNT=CNT+1 114 . . S ^OR(100,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2) 115 . . S:$L($P(ITM,U,2)) ^OR(100,ORIFN,4.5,"ID",$P(ITM,U,2),CNT)="" 116 . . S:TYPE'="W" ^OR(100,ORIFN,4.5,CNT,1)=VALUE 117 . . M:TYPE="W" ^OR(100,ORIFN,4.5,CNT,2)=@VALUE ; array root 118 S ^OR(100,ORIFN,4.5,0)="^100.045A^"_CNT_U_CNT 119 R1 ; [Reset] Orderables 120 I $D(^OR(100,ORIFN,.1)) S I=0 F S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0 S X=$G(^(I,0)) I X,PAT,START K ^OR(100,"AOI",X,PAT,9999999-START,ORIFN) ; kill xref 121 K ^OR(100,ORIFN,.1) I $D(^OR(100,ORIFN,4.5,"ID","ORDERABLE")) D 122 . S (I,CNT)=0 123 . F S I=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D 124 . . S X=$G(^OR(100,ORIFN,4.5,I,1)) Q:'X 125 . . S CNT=CNT+1,^OR(100,ORIFN,.1,CNT,0)=X,^OR(100,ORIFN,.1,"B",X,CNT)="" 126 . . I PAT,START S ^OR(100,"AOI",X,PAT,9999999-START,ORIFN)="" 127 . S ^OR(100,ORIFN,.1,0)="^100.001PA^"_CNT_U_CNT 128 Q 129 ; 130 RESUME(IFN) ; -- add Response nodes for RESUME tray service 131 ; S ^OR(100,+IFN,4.5,<next>,0)=DT_"^^^RESUME",^(1)=1 132 ; 133 N X,Y,DA,DIC 134 S DIC="^OR(100,"_+IFN_",4.5,",DIC(0)="LX",DA(1)=+IFN,X=DT 135 S DIC("DR")=".04///RESUME",DIC("P")=$P(^DD(100,4.5,0),U,2) 136 D ^DIC S:Y ^OR(100,+IFN,4.5,+Y,1)=1 137 Q 138 ; 139 PROVIDER(ORDER,PROV) ; -- Change PROVider assigned to ORDER 140 Q:'$G(ORDER) Q:'$G(PROV) 141 N ORACT S ORACT=+$P(ORDER,";",2) S:'ORACT ORACT=1 142 S $P(^OR(100,+ORDER,8,ORACT,0),U,3)=PROV 143 S:ORACT=1 $P(^OR(100,+ORDER,0),U,4)=PROV 144 Q 145 ; 146 ACTION(CODE,DA,PROV,REASON,WHEN,WHO) ; -- save new action 147 N NEXT,TOTAL,HDR,LAST,X,PAT,DGRP,SIG,NATR,TXT S DA=+DA 148 Q:'$D(^OR(100,DA,0)) 0 Q:$G(CODE)'?2U 0 149 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ 150 S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed 151 S PAT=$P(^OR(100,DA,0),U,2),DGRP=$P(^(0),U,11),SIG=$P(^(0),U,16),X=+$P($G(^(3)),U,7),HDR=$G(^(8,0)) 152 S:X'>0 X=1 S TXT=$P($G(^OR(100,DA,8,X,0)),U,14) ;current actn's txt ptr 153 S:HDR="" HDR="^100.008DA^^" S TOTAL=+$P(HDR,U,4) 154 S LAST=$O(^OR(100,DA,8,"C",CODE,"?"),-1) I LAST D 155 . S X=$G(^OR(100,DA,8,LAST,0)) Q:$P(X,U,15)'=11 Q:$P(X,U,4)'=2 156 . S NEXT=LAST I PAT,$P(X,U) D ; kill old xref entries 157 . . K:DGRP ^OR(100,"ACT",PAT,(9999999-$P(X,U)),DGRP,DA,NEXT) 158 . . K ^OR(100,"AC",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AS",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AF",$P(X,U),DA,NEXT) 159 S:'$G(NEXT) NEXT=$O(^OR(100,DA,8,"?"),-1)+1,TOTAL=TOTAL+1 160 S ^OR(100,DA,8,NEXT,0)=WHEN_U_CODE_U_$G(PROV)_U_$S(SIG:2,1:3)_"^^^^^^^^"_NATR_U_WHO_U_TXT_"^11",^OR(100,DA,8,"C",CODE,NEXT)="" 161 S ^OR(100,"AF",WHEN,DA,NEXT)="" 162 I PAT,DGRP S ^OR(100,"ACT",PAT,9999999-WHEN,DGRP,DA,NEXT)="" 163 I PAT S ^OR(100,"AC",PAT,9999999-WHEN,DA,NEXT)="" 164 I SIG S ^OR(100,"AS",PAT,9999999-WHEN,DA,NEXT)="" 165 S:$L($G(REASON)) ^OR(100,DA,8,NEXT,1)=REASON 166 S $P(HDR,U,3,4)=NEXT_U_TOTAL,^OR(100,DA,8,0)=HDR 167 Q NEXT 168 ; 169 SET(DLG) ; -- Create new parent for order set ORDIALOG 170 ; Returns ORPIFN = ifn of new parent order for set 171 ; 172 Q:'$G(ORVP) Q:'$G(DLG) N OR0,PKG,NOW,CATG,STS,ORLOC,TRSPEC,X 173 S OR0=$G(^ORD(101.41,DLG,0)) Q:OR0="" S ORPIFN=$$NEXTIFN Q:'ORPIFN 174 S PKG=$O(^DIC(9.4,"C","OR",0)),CATG=$S($$INPT^ORCD:"I",1:"O"),STS=$S($G(OREVENT):10,1:11),NOW=$S($G(ORSLOG):ORSLOG,1:+$E($$NOW^XLFDT,1,12)) 175 I $G(OREVENT) S ORLOC="",TRSPEC="" 176 S ^OR(100,ORPIFN,0)=ORPIFN_U_ORVP_U_U_$G(ORNP)_U_DLG_";ORD(101.41,^"_DUZ_U_NOW_U_U_U_ORLOC_U_U_CATG_U_TRSPEC_U_PKG_"^^^"_$G(OREVENT),^(3)=NOW_"^90^"_STS_U_$S($G(ORIT):ORIT_"ORD(101.41,",1:"")_"^^^1^^^^0^^"_+$P(OR0,U,6) 177 S ^OR(100,ORPIFN,8,0)="^100.008DA^1^1",^(1,0)=NOW_"^NW^"_$G(ORNP)_"^^^^^^^^^^"_DUZ_"^^"_STS,^OR(100,ORPIFN,8,"C","NW",1)="",^OR(100,"AF",NOW,ORPIFN,1)="" 178 S ^OR(100,"ACT",ORVP,9999999-NOW,ORPIFN,1)="" 179 S:STS=11 ^OR(100,"AC",ORVP,9999999-NOW,ORPIFN,1)="" 180 ; AEVNT ?? 181 S ^OR(100,ORPIFN,1,0)="^100.011^1^1",^(1,0)=$P(OR0,U,2) ; Order text 182 Q
Note:
See TracChangeset
for help on using the changeset viewer.
