- 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/ORCD.m
r613 r623 1 ORCD ; SLC/MKB - Order Dialog utilities ;12/15/2006 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,38,68,94,161,141,195,215,243**;Dec 17,1997;Build 242 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 INPT() ; -- Return 1 or 0, if patient/order sheet = inpatient 5 N Y S Y=$S($G(ORWARD):1,$G(^DPT(+ORVP,.105)):1,1:0) 6 I $G(OREVENT) D ;override if delayed order 7 . N X,X0 S X=$$EVT^OREVNTX(+OREVENT),X0=$G(^ORD(100.5,+X,0)) 8 . I $P(X0,U,12) S X0=$G(^ORD(100.5,$P(X0,U,12),0)) ;use parent 9 . S X=$P(X0,U,2) Q:X="M" Q:X="O" ;M/O keep current inpt status 10 . S Y=$S(X="A":1,X="T":1,1:0) 11 . I X="D",$P(X0,U,7)=41 S Y=1 ;From ASIH = Inpt 12 . I X="T",$P(X0,U,7),$P(X0,U,7)<4 S Y=0 ;pass = Outpt 13 Q Y 14 ; 15 EXT(P,I,F) ; -- Returns external value of ORDIALOG(Prompt,Instance) 16 N TYPE,PARAM,FNUM,IENS,X,Y,J,Z 17 S TYPE=$E($G(ORDIALOG(P,0))),PARAM=$P($G(ORDIALOG(P,0)),U,2) 18 S X=$G(ORDIALOG(P,I)) I X="" Q "" 19 I TYPE="N",X<1 S X=0_+X I X="00" S X=0 20 I "FNW"[TYPE Q X 21 I TYPE="Y" Q $S(X:"YES",X=0:"NO",1:"") 22 I TYPE="D" S:'$L($G(F)) F=1 Q $$FMTE^XLFDT(X,F) 23 I TYPE="R" Q $$FTDATE(X,$G(F)) ; DAY@TIME 24 I TYPE="P" D Q Y 25 . S PARAM=$P(PARAM,":"),FNUM=$S(PARAM:+PARAM,1:+$P(@(U_PARAM_"0)"),U,2)) 26 . S IENS=+X_",",J=$L(PARAM,",") I J>2 F S J=J-2 Q:J'>0 S Z=$P(PARAM,",",J),IENS=IENS_$S(Z:Z,1:+$P(Z,"(",2))_"," 27 . S:'+$G(F) F=.01 S Y=$$GET1^DIQ(FNUM,IENS,+F) 28 . I Y="",F'=.01 S Y=$$GET1^DIQ(FNUM,IENS,.01) 29 I TYPE="S" F J=1:1:$L(PARAM,";") S Z=$P(PARAM,";",J) I $P(Z,":")=X S Y=$S(+$G(F):X,1:$P(Z,":",2)) Q 30 Q $G(Y) 31 ; 32 FTDATE(X,F) ; -- Returns free text form of date (i.e. TODAY) 33 N D,T,P,Y I X="" Q "" 34 S X=$$UP^XLFSTR(X),D=$P(X,"@"),T=$P(X,"@",2) ; D=date,T=time parts 35 I "NOW"[X Q "NOW" 36 I "NOON"[X Q "NOON" 37 I $E("MIDNIGHT",1,$L(X))=X Q "MIDNIGHT" 38 I (X="AM")!(X="NEXT") Q X_" Lab collection" 39 I (X="NEXTA")!(X="CLOSEST") Q $S(X="NEXTA":"NEXT",1:X)_" administration time" 40 I $E(D)'="T",$E(D)'="V",($E(D)'="N"!($E(D,1,3)="NOV")) D Q $$FMTE^XLFDT(X,F) 41 . N %DT S %DT="TX" D ^%DT S:Y>0 X=Y S:'$G(F) F=1 42 S P=$S(D["+":"+",D["-":"-",1:"") 43 I P="" S Y=$S($E(D)="T":"TODAY",$E(D)="V":"NEXT VISIT",1:"NOW") 44 FTD1 E D 45 . N OFFSET,NUM,UNIT 46 . S OFFSET=$P(D,P,2),NUM=+OFFSET,UNIT=$E($P(OFFSET,NUM,2)) ; +/-#D 47 . I $E(D)="T",NUM=1,UNIT=""!(UNIT="D") S Y=$S(P="+":"TOMORROW",1:"YESTERDAY") Q 48 . S Y=NUM_" "_$S(UNIT="'":"MINUTE",UNIT="H":"HOUR",UNIT="W":"WEEK",UNIT="M":"MONTH",1:"DAY") 49 . S:NUM>1 Y=Y_"S" ; plural 50 . S:$E(D)="N" Y=Y_" "_$S(P="+":"FROM NOW",1:"AGO") 51 . S:$E(D)="T" Y=Y_" "_$S(P="+":"FROM TODAY",1:"AGO") 52 . S:$E(D)="V" Y=Y_" "_$S(P="+":"AFTER",1:"BEFORE")_" NEXT VISIT" 53 I $L(T) S Y=Y_"@"_$$TIME(T) 54 Q Y 55 ; 56 FTDHELP ; -- Displays ??-help for R-type prompts 57 G R^ORCDLGH 58 Q 59 ; 60 FTDCOMP(X1,X2,OPER) ; -- Compares free text dates from prompts X1 & X2 61 ; Returns 1 or 0, IF $$VAL(X1)<OPER>$$VAL(X2) is true 62 N X,Y,Y1,Y2,Z,%DT 63 S X=$$VAL(X1),%DT="TX" D ^%DT S Y1=Y ; Y'>0 ?? 64 S X=$$VAL(X2),%DT="TX" D ^%DT S Y2=Y ; Y'>0 ?? 65 S Z="I "_Y1_OPER_Y2 X Z 66 Q $T 67 ; 68 TIME(X) ; -- Returns 00:00 PM formatted time 69 N Y,Z,%DT 70 I X?1U,"BNE"[X Q $S(X="B":"BREAKFAST",X="N":"NOON",X="E":"EVENING",1:"") 71 I "NOON"[X Q X 72 I "MIDNIGHT"[X Q "MIDNIGHT" 73 S X="T@"_X,%DT="TX" D ^%DT I Y'>0 Q "" 74 S Z=$$FMTE^XLFDT(Y,"2P"),Z=$P(Z," ",2)_$$UP^XLFSTR($P(Z," ",3)) 75 Q Z 76 ; 77 VAL(TEXT,INST) ; -- Returns internal form of TEXT's current value 78 N I,X S X="" S:'$G(INST) INST=1 79 I '$D(ORDIALOG("B",TEXT)) S I=$O(ORDIALOG("B",TEXT)) Q:$E(I,1,$L(TEXT))'=TEXT X S TEXT=I ; partial match 80 S X=$P($G(ORDIALOG("B",TEXT)),U,2) ; ptr 81 Q $G(ORDIALOG(X,INST)) 82 ; 83 ORDMSG(OI) ; -- Display order message for orderable OI 84 Q:'$O(^ORD(101.43,OI,8,0)) ; no order message 85 N I S I=0 W ! 86 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 W !,$G(^(I,0)) 87 W ! Q 88 ; 89 PTR(NAME) ; -- Returns pointer to Dialog file for prompt NAME 90 Q +$O(^ORD(101.41,"AB",$E(NAME,1,63),0)) 91 ; 92 NMSP(PKG) ; -- Returns package namespace from pointer 93 N Y S Y=$$GET1^DIQ(9.4,+PKG_",",1) 94 S:$E(Y,1,2)="PS" Y="PS" S:Y="GMRV" Y="OR" 95 Q Y 96 ; 97 GETQDLG(QIFN) ; -- define ORDIALOG(PROMPT) for quick order QIFN 98 S ORDIALOG=$$DEFDLG(QIFN) Q:'ORDIALOG 99 D GETDLG(ORDIALOG),GETORDER("^ORD(101.41,"_QIFN_",6)") 100 X:$D(^ORD(101.41,QIFN,3)) ^(3) ; entry action for quick order 101 Q 102 ; 103 DEFDLG(QDLG) ; -- Returns default dialog for QDLG 104 N DG,DLG,TOP S DG=+$P($G(^ORD(101.41,+QDLG,0)),U,5) 105 S DLG=+$P($G(^ORD(100.98,DG,0)),U,4) ; default dialog 106 I 'DLG S TOP=+$O(^ORD(100.98,"AD",DG,0)),DLG=+$P($G(^ORD(100.98,TOP,0)),U,4) 107 Q DLG 108 ; 109 GETDLG(IFN) ; -- define ORDIALOG(PROMPT) for dialog IFN 110 N SEQ,DA,ITEM,PTR,PROMPT,TEXT,INDEX,HELP,XHELP,SCREEN,ORD,INPUTXFM,LKP 111 S SEQ=0 K ^TMP("ORWORD",$J) 112 F S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA D 113 . S ITEM=$G(^ORD(101.41,IFN,10,DA,0)),INPUTXFM=$G(^(.1)),HELP=$G(^(1)),SCREEN=$G(^(4)),XHELP=$G(^(6)) 114 . S PTR=$P(ITEM,U,2),TEXT=$P(ITEM,U,4),INDEX=$P(ITEM,U,10) Q:'PTR 115 . S:'$L(TEXT) TEXT=$P(^ORD(101.41,PTR,0),U,2) K ORD 116 . S PROMPT=$G(^ORD(101.41,PTR,1)),ORD=DA_U_$P(PROMPT,U,3) 117 . S ORD(0)=$P(PROMPT,U)_$S($P(PROMPT,U)="S":"M",1:"")_U_$P(PROMPT,U,2)_$S($L(INPUTXFM):U_INPUTXFM,1:"") 118 . S ORD("A")=TEXT S:$L($P(ITEM,U,13)) ORD("TTL")=$P(ITEM,U,13) 119 . I $P(ITEM,U,7) S ORD("MAX")=$P(ITEM,U,12),ORD("MORE")=$P(ITEM,U,14) ; fields for multiples 120 . I $L(HELP) S LKP=$P(HELP,U,2),HELP=$P(HELP,U) S:$L(HELP) ORD("?")=HELP S:$L(LKP) ORD("LKP")=$S($L(LKP,";")>1:$TR(LKP,";","^"),1:U_LKP) 121 . S:$L(XHELP) ORD("??")=U_XHELP 122 . S:$L(INDEX) ORD("D")=INDEX 123 . S:$L(SCREEN) ORD("S")=SCREEN 124 . S ORDIALOG("B",$$UP^XLFSTR($P(TEXT,":")))=SEQ_U_PTR 125 . M ORDIALOG(PTR)=ORD 126 Q 127 ; 128 GETDLG1(IFN) ; -- basic ORDIALOG(PROMPT) for dialog IFN 129 N SEQ,DA,PROMPT,PTR,WINCTRL 130 K ^TMP("ORWORD",$J) S SEQ=0 131 F S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA D 132 . S PTR=$P($G(^ORD(101.41,IFN,10,DA,0)),U,2) Q:'PTR 133 . S WINCTRL=$P($G(^ORD(101.41,IFN,10,DA,"W")),U) 134 . S PROMPT=$G(^ORD(101.41,PTR,1)) Q:'$L(PROMPT) 135 . S ORDIALOG(PTR)=DA_U_$P(PROMPT,U,3)_U_WINCTRL 136 . S ORDIALOG(PTR,0)=$P(PROMPT,U,1,2) 137 Q 138 ; 139 GETORDER(ROOT,ARRAY) ; -- retrieve order values from RESPONSES in ARRAY() 140 N ORI,ID,PTR,INST,TYPE,DA,X,ORTXT S:'$L($G(ARRAY)) ARRAY="ORDIALOG" 141 I +ROOT=ROOT S ROOT="^OR(100,"_ROOT_",4.5)" ; assume Orders file IFN 142 S ORI=0 F S ORI=$O(@ROOT@(ORI)) Q:ORI'>0 S ID=$G(@ROOT@(ORI,0)) D 143 . S DA=$P(ID,U),PTR=$P(ID,U,2),INST=$P(ID,U,3) S:'INST INST=1 144 . S:'PTR PTR=$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) Q:'PTR 145 . Q:'$D(ORDIALOG(PTR)) S TYPE=$E($G(ORDIALOG(PTR,0))) Q:'$L(TYPE) 146 . I TYPE'="W" S X=$G(@ROOT@(ORI,1)) S:$L(X) @ARRAY@(PTR,INST)=X Q 147 . D RESTXT ;resolve objects 148 . I ARRAY="ORDIALOG" M ^TMP("ORWORD",$J,PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)="^TMP(""ORWORD"","_$J_","_PTR_","_INST_")" 149 . I ARRAY'="ORDIALOG" M @ARRAY@(PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)=$NA(@ARRAY@(PTR,INST)) 150 . K @ORTXT 151 Q 152 ; 153 RESTXT ; -- resolve objects in text [from GETORDER+8] 154 I $$BROKER^XWBLIB!($G(ORTYPE)="Z") M ^TMP("ORX",$J)=@ROOT@(ORI,2) S ORTXT=$NA(^TMP("ORX",$J)) Q ;return text unresolved 155 N ARRAY,PTR,INST 156 D BLRPLT^TIUSRVD(.ORTXT,,+$G(ORVP),,$NA(@ROOT@(ORI,2))) 157 Q 158 ; 159 DUP(PROMPT,CURRENT) ; -- Compare CURRENT instance of PROMPT for duplicates 160 N X,Y,I 161 S X=ORDIALOG(PROMPT,CURRENT),Y=0 162 S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 I I'=CURRENT,$P(ORDIALOG(PROMPT,I),U)=$P(ORDIALOG(PROMPT,CURRENT),U) S Y=1 Q 163 Q Y 164 ; 165 LIST ; -- Show contents of ORDIALOG(PROMPT,"LIST") 166 N NUM S NUM=$G(ORDIALOG(PROMPT,"LIST")) Q:'NUM 167 W !,"Choose from"_$S('$P(NUM,U,2):" (or enter another):",1:":") 168 LIST1 N I,DONE,CNT S (I,CNT,DONE)=0 169 F S I=$O(ORDIALOG(PROMPT,"LIST",I)) Q:I'>0 D Q:DONE 170 . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE S DONE=1 Q 171 . W !,$J(I,6)_" "_$P(ORDIALOG(PROMPT,"LIST",I),U,2) 172 Q 173 ; 174 SETLIST ; -- Show allowable set of codes 175 W !,"Choose from:" 176 SETLST1 N I,X F I=1:1:$L(DOMAIN,";") S X=$P(DOMAIN,";",I) I $L(X) D 177 . W !,?5,$P(X,":"),?15,$P(X,":",2) 178 Q 179 ; 180 MORE() ; -- show more? 181 N X,Y,DIR 182 S DIR(0)="EA",DIR("A")=" press <return> to continue or ^ to exit ..." 183 D ^DIR 184 Q +Y 185 ; 186 FIRST(P,I) ; -- Returns 1 or 0, if current instance I is first of multiple 187 Q '$O(ORDIALOG(P,I),-1) 188 ; 189 RECALL(P,I) ; -- Returns first value for prompt P, instance I 190 N Y S:'$G(I) I=1 S Y=$G(^TMP("ORECALL",$J,+ORDIALOG,P,I)) 191 Q Y 1 ORCD ; SLC/MKB - Order Dialog utilities ;9/21/2005 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,38,68,94,161,141,195,215**;Dec 17,1997 3 INPT() ; -- Return 1 or 0, if patient/order sheet = inpatient 4 N Y S Y=$S($G(ORWARD):1,$G(^DPT(+ORVP,.105)):1,1:0) 5 I $G(OREVENT) D ;override if delayed order 6 . N X,X0 S X=$$EVT^OREVNTX(+OREVENT),X0=$G(^ORD(100.5,+X,0)) 7 . I $P(X0,U,12) S X0=$G(^ORD(100.5,$P(X0,U,12),0)) ;use parent 8 . S X=$P(X0,U,2) Q:X="M" Q:X="O" ;M/O keep current inpt status 9 . S Y=$S(X="A":1,X="T":1,1:0) 10 . I X="D",$P(X0,U,7)=41 S Y=1 ;From ASIH = Inpt 11 . I X="T",$P(X0,U,7),$P(X0,U,7)<4 S Y=0 ;pass = Outpt 12 Q Y 13 ; 14 EXT(P,I,F) ; -- Returns external value of ORDIALOG(Prompt,Instance) 15 N TYPE,PARAM,FNUM,IENS,X,Y,J,Z 16 S TYPE=$E($G(ORDIALOG(P,0))),PARAM=$P($G(ORDIALOG(P,0)),U,2) 17 S X=$G(ORDIALOG(P,I)) I X="" Q "" 18 I "FNW"[TYPE Q X 19 I TYPE="Y" Q $S(X:"YES",X=0:"NO",1:"") 20 I TYPE="D" S:'$L($G(F)) F=1 Q $$FMTE^XLFDT(X,F) 21 I TYPE="R" Q $$FTDATE(X,$G(F)) ; DAY@TIME 22 I TYPE="P" D Q Y 23 . S PARAM=$P(PARAM,":"),FNUM=$S(PARAM:+PARAM,1:+$P(@(U_PARAM_"0)"),U,2)) 24 . S IENS=+X_",",J=$L(PARAM,",") I J>2 F S J=J-2 Q:J'>0 S Z=$P(PARAM,",",J),IENS=IENS_$S(Z:Z,1:+$P(Z,"(",2))_"," 25 . S:'+$G(F) F=.01 S Y=$$GET1^DIQ(FNUM,IENS,+F) 26 . I Y="",F'=.01 S Y=$$GET1^DIQ(FNUM,IENS,.01) 27 I TYPE="S" F J=1:1:$L(PARAM,";") S Z=$P(PARAM,";",J) I $P(Z,":")=X S Y=$S(+$G(F):X,1:$P(Z,":",2)) Q 28 Q $G(Y) 29 ; 30 FTDATE(X,F) ; -- Returns free text form of date (i.e. TODAY) 31 N D,T,P,Y I X="" Q "" 32 S X=$$UP^XLFSTR(X),D=$P(X,"@"),T=$P(X,"@",2) ; D=date,T=time parts 33 I "NOW"[X Q "NOW" 34 I "NOON"[X Q "NOON" 35 I $E("MIDNIGHT",1,$L(X))=X Q "MIDNIGHT" 36 I (X="AM")!(X="NEXT") Q X_" Lab collection" 37 I (X="NEXTA")!(X="CLOSEST") Q $S(X="NEXTA":"NEXT",1:X)_" administration time" 38 I $E(D)'="T",$E(D)'="V",($E(D)'="N"!($E(D,1,3)="NOV")) D Q $$FMTE^XLFDT(X,F) 39 . N %DT S %DT="TX" D ^%DT S:Y>0 X=Y S:'$G(F) F=1 40 S P=$S(D["+":"+",D["-":"-",1:"") 41 I P="" S Y=$S($E(D)="T":"TODAY",$E(D)="V":"NEXT VISIT",1:"NOW") 42 FTD1 E D 43 . N OFFSET,NUM,UNIT 44 . S OFFSET=$P(D,P,2),NUM=+OFFSET,UNIT=$E($P(OFFSET,NUM,2)) ; +/-#D 45 . I $E(D)="T",NUM=1,UNIT=""!(UNIT="D") S Y=$S(P="+":"TOMORROW",1:"YESTERDAY") Q 46 . S Y=NUM_" "_$S(UNIT="'":"MINUTE",UNIT="H":"HOUR",UNIT="W":"WEEK",UNIT="M":"MONTH",1:"DAY") 47 . S:NUM>1 Y=Y_"S" ; plural 48 . S:$E(D)="N" Y=Y_" "_$S(P="+":"FROM NOW",1:"AGO") 49 . S:$E(D)="T" Y=Y_" "_$S(P="+":"FROM TODAY",1:"AGO") 50 . S:$E(D)="V" Y=Y_" "_$S(P="+":"AFTER",1:"BEFORE")_" NEXT VISIT" 51 I $L(T) S Y=Y_"@"_$$TIME(T) 52 Q Y 53 ; 54 FTDHELP ; -- Displays ??-help for R-type prompts 55 G R^ORCDLGH 56 Q 57 ; 58 FTDCOMP(X1,X2,OPER) ; -- Compares free text dates from prompts X1 & X2 59 ; Returns 1 or 0, IF $$VAL(X1)<OPER>$$VAL(X2) is true 60 N X,Y,Y1,Y2,Z,%DT 61 S X=$$VAL(X1),%DT="TX" D ^%DT S Y1=Y ; Y'>0 ?? 62 S X=$$VAL(X2),%DT="TX" D ^%DT S Y2=Y ; Y'>0 ?? 63 S Z="I "_Y1_OPER_Y2 X Z 64 Q $T 65 ; 66 TIME(X) ; -- Returns 00:00 PM formatted time 67 N Y,Z,%DT 68 I "NOON"[X Q X 69 I "MIDNIGHT"[X Q "MIDNIGHT" 70 I X?1U,"BNE"[X Q $S(X="B":"BREAKFAST",X="N":"NOON",X="E":"EVENING",1:"") 71 S X="T@"_X,%DT="TX" D ^%DT I Y'>0 Q "" 72 S Z=$$FMTE^XLFDT(Y,"2P"),Z=$P(Z," ",2)_$$UP^XLFSTR($P(Z," ",3)) 73 Q Z 74 ; 75 VAL(TEXT,INST) ; -- Returns internal form of TEXT's current value 76 N I,X S X="" S:'$G(INST) INST=1 77 I '$D(ORDIALOG("B",TEXT)) S I=$O(ORDIALOG("B",TEXT)) Q:$E(I,1,$L(TEXT))'=TEXT X S TEXT=I ; partial match 78 S X=$P($G(ORDIALOG("B",TEXT)),U,2) ; ptr 79 Q $G(ORDIALOG(X,INST)) 80 ; 81 ORDMSG(OI) ; -- Display order message for orderable OI 82 Q:'$O(^ORD(101.43,OI,8,0)) ; no order message 83 N I S I=0 W ! 84 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 W !,$G(^(I,0)) 85 W ! Q 86 ; 87 PTR(NAME) ; -- Returns pointer to Dialog file for prompt NAME 88 Q +$O(^ORD(101.41,"AB",$E(NAME,1,63),0)) 89 ; 90 NMSP(PKG) ; -- Returns package namespace from pointer 91 N Y S Y=$$GET1^DIQ(9.4,+PKG_",",1) 92 S:$E(Y,1,2)="PS" Y="PS" S:Y="GMRV" Y="OR" 93 Q Y 94 ; 95 GETQDLG(QIFN) ; -- define ORDIALOG(PROMPT) for quick order QIFN 96 S ORDIALOG=$$DEFDLG(QIFN) Q:'ORDIALOG 97 D GETDLG(ORDIALOG),GETORDER("^ORD(101.41,"_QIFN_",6)") 98 X:$D(^ORD(101.41,QIFN,3)) ^(3) ; entry action for quick order 99 Q 100 ; 101 DEFDLG(QDLG) ; -- Returns default dialog for QDLG 102 N DG,DLG,TOP S DG=+$P($G(^ORD(101.41,+QDLG,0)),U,5) 103 S DLG=+$P($G(^ORD(100.98,DG,0)),U,4) ; default dialog 104 I 'DLG S TOP=+$O(^ORD(100.98,"AD",DG,0)),DLG=+$P($G(^ORD(100.98,TOP,0)),U,4) 105 Q DLG 106 ; 107 GETDLG(IFN) ; -- define ORDIALOG(PROMPT) for dialog IFN 108 N SEQ,DA,ITEM,PTR,PROMPT,TEXT,INDEX,HELP,XHELP,SCREEN,ORD,INPUTXFM,LKP 109 S SEQ=0 K ^TMP("ORWORD",$J) 110 F S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA D 111 . S ITEM=$G(^ORD(101.41,IFN,10,DA,0)),INPUTXFM=$G(^(.1)),HELP=$G(^(1)),SCREEN=$G(^(4)),XHELP=$G(^(6)) 112 . S PTR=$P(ITEM,U,2),TEXT=$P(ITEM,U,4),INDEX=$P(ITEM,U,10) Q:'PTR 113 . S:'$L(TEXT) TEXT=$P(^ORD(101.41,PTR,0),U,2) K ORD 114 . S PROMPT=$G(^ORD(101.41,PTR,1)),ORD=DA_U_$P(PROMPT,U,3) 115 . S ORD(0)=$P(PROMPT,U)_$S($P(PROMPT,U)="S":"M",1:"")_U_$P(PROMPT,U,2)_$S($L(INPUTXFM):U_INPUTXFM,1:"") 116 . S ORD("A")=TEXT S:$L($P(ITEM,U,13)) ORD("TTL")=$P(ITEM,U,13) 117 . I $P(ITEM,U,7) S ORD("MAX")=$P(ITEM,U,12),ORD("MORE")=$P(ITEM,U,14) ; fields for multiples 118 . I $L(HELP) S LKP=$P(HELP,U,2),HELP=$P(HELP,U) S:$L(HELP) ORD("?")=HELP S:$L(LKP) ORD("LKP")=$S($L(LKP,";")>1:$TR(LKP,";","^"),1:U_LKP) 119 . S:$L(XHELP) ORD("??")=U_XHELP 120 . S:$L(INDEX) ORD("D")=INDEX 121 . S:$L(SCREEN) ORD("S")=SCREEN 122 . S ORDIALOG("B",$$UP^XLFSTR($P(TEXT,":")))=SEQ_U_PTR 123 . M ORDIALOG(PTR)=ORD 124 Q 125 ; 126 GETDLG1(IFN) ; -- basic ORDIALOG(PROMPT) for dialog IFN 127 N SEQ,DA,PROMPT,PTR,WINCTRL 128 K ^TMP("ORWORD",$J) S SEQ=0 129 F S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA D 130 . S PTR=$P($G(^ORD(101.41,IFN,10,DA,0)),U,2) Q:'PTR 131 . S WINCTRL=$P($G(^ORD(101.41,IFN,10,DA,"W")),U) 132 . S PROMPT=$G(^ORD(101.41,PTR,1)) Q:'$L(PROMPT) 133 . S ORDIALOG(PTR)=DA_U_$P(PROMPT,U,3)_U_WINCTRL 134 . S ORDIALOG(PTR,0)=$P(PROMPT,U,1,2) 135 Q 136 ; 137 GETORDER(ROOT,ARRAY) ; -- retrieve order values from RESPONSES in ARRAY() 138 N ORI,ID,PTR,INST,TYPE,DA,X,ORTXT S:'$L($G(ARRAY)) ARRAY="ORDIALOG" 139 I +ROOT=ROOT S ROOT="^OR(100,"_ROOT_",4.5)" ; assume Orders file IFN 140 S ORI=0 F S ORI=$O(@ROOT@(ORI)) Q:ORI'>0 S ID=$G(@ROOT@(ORI,0)) D 141 . S DA=$P(ID,U),PTR=$P(ID,U,2),INST=$P(ID,U,3) S:'INST INST=1 142 . S:'PTR PTR=$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) Q:'PTR 143 . Q:'$D(ORDIALOG(PTR)) S TYPE=$E($G(ORDIALOG(PTR,0))) Q:'$L(TYPE) 144 . I TYPE'="W" S X=$G(@ROOT@(ORI,1)) S:$L(X) @ARRAY@(PTR,INST)=X Q 145 . D RESTXT ;resolve objects 146 . I ARRAY="ORDIALOG" M ^TMP("ORWORD",$J,PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)="^TMP(""ORWORD"","_$J_","_PTR_","_INST_")" 147 . I ARRAY'="ORDIALOG" M @ARRAY@(PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)=$NA(@ARRAY@(PTR,INST)) 148 . K @ORTXT 149 Q 150 ; 151 RESTXT ; -- resolve objects in text [from GETORDER+8] 152 I $$BROKER^XWBLIB!($G(ORTYPE)="Z") M ^TMP("ORX",$J)=@ROOT@(ORI,2) S ORTXT=$NA(^TMP("ORX",$J)) Q ;return text unresolved 153 N ARRAY,PTR,INST 154 D BLRPLT^TIUSRVD(.ORTXT,,+$G(ORVP),,$NA(@ROOT@(ORI,2))) 155 Q 156 ; 157 DUP(PROMPT,CURRENT) ; -- Compare CURRENT instance of PROMPT for duplicates 158 N X,Y,I 159 S X=ORDIALOG(PROMPT,CURRENT),Y=0 160 S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 I I'=CURRENT,$P(ORDIALOG(PROMPT,I),U)=$P(ORDIALOG(PROMPT,CURRENT),U) S Y=1 Q 161 Q Y 162 ; 163 LIST ; -- Show contents of ORDIALOG(PROMPT,"LIST") 164 N NUM S NUM=$G(ORDIALOG(PROMPT,"LIST")) Q:'NUM 165 W !,"Choose from"_$S('$P(NUM,U,2):" (or enter another):",1:":") 166 LIST1 N I,DONE,CNT S (I,CNT,DONE)=0 167 F S I=$O(ORDIALOG(PROMPT,"LIST",I)) Q:I'>0 D Q:DONE 168 . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE S DONE=1 Q 169 . W !,$J(I,6)_" "_$P(ORDIALOG(PROMPT,"LIST",I),U,2) 170 Q 171 ; 172 SETLIST ; -- Show allowable set of codes 173 W !,"Choose from:" 174 SETLST1 N I,X F I=1:1:$L(DOMAIN,";") S X=$P(DOMAIN,";",I) I $L(X) D 175 . W !,?5,$P(X,":"),?15,$P(X,":",2) 176 Q 177 ; 178 MORE() ; -- show more? 179 N X,Y,DIR 180 S DIR(0)="EA",DIR("A")=" press <return> to continue or ^ to exit ..." 181 D ^DIR 182 Q +Y 183 ; 184 FIRST(P,I) ; -- Returns 1 or 0, if current instance I is first of multiple 185 Q '$O(ORDIALOG(P,I),-1) 186 ; 187 RECALL(P,I) ; -- Returns first value for prompt P, instance I 188 N Y S:'$G(I) I=1 S Y=$G(^TMP("ORECALL",$J,+ORDIALOG,P,I)) 189 Q Y
Note:
See TracChangeset
for help on using the changeset viewer.
