- ORCD ; SLC/MKB - Order Dialog utilities ;12/15/2006
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,38,68,94,161,141,195,215,243**;Dec 17,1997;Build 242
- ;Per VHA Directive 2004-038, this routine should not be modified.
- INPT() ; -- Return 1 or 0, if patient/order sheet = inpatient
- N Y S Y=$S($G(ORWARD):1,$G(^DPT(+ORVP,.105)):1,1:0)
- I $G(OREVENT) D ;override if delayed order
- . N X,X0 S X=$$EVT^OREVNTX(+OREVENT),X0=$G(^ORD(100.5,+X,0))
- . I $P(X0,U,12) S X0=$G(^ORD(100.5,$P(X0,U,12),0)) ;use parent
- . S X=$P(X0,U,2) Q:X="M" Q:X="O" ;M/O keep current inpt status
- . S Y=$S(X="A":1,X="T":1,1:0)
- . I X="D",$P(X0,U,7)=41 S Y=1 ;From ASIH = Inpt
- . I X="T",$P(X0,U,7),$P(X0,U,7)<4 S Y=0 ;pass = Outpt
- Q Y
- ;
- EXT(P,I,F) ; -- Returns external value of ORDIALOG(Prompt,Instance)
- N TYPE,PARAM,FNUM,IENS,X,Y,J,Z
- S TYPE=$E($G(ORDIALOG(P,0))),PARAM=$P($G(ORDIALOG(P,0)),U,2)
- S X=$G(ORDIALOG(P,I)) I X="" Q ""
- I TYPE="N",X<1 S X=0_+X I X="00" S X=0
- I "FNW"[TYPE Q X
- I TYPE="Y" Q $S(X:"YES",X=0:"NO",1:"")
- I TYPE="D" S:'$L($G(F)) F=1 Q $$FMTE^XLFDT(X,F)
- I TYPE="R" Q $$FTDATE(X,$G(F)) ; DAY@TIME
- I TYPE="P" D Q Y
- . S PARAM=$P(PARAM,":"),FNUM=$S(PARAM:+PARAM,1:+$P(@(U_PARAM_"0)"),U,2))
- . 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))_","
- . S:'+$G(F) F=.01 S Y=$$GET1^DIQ(FNUM,IENS,+F)
- . I Y="",F'=.01 S Y=$$GET1^DIQ(FNUM,IENS,.01)
- 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
- Q $G(Y)
- ;
- FTDATE(X,F) ; -- Returns free text form of date (i.e. TODAY)
- N D,T,P,Y I X="" Q ""
- S X=$$UP^XLFSTR(X),D=$P(X,"@"),T=$P(X,"@",2) ; D=date,T=time parts
- I "NOW"[X Q "NOW"
- I "NOON"[X Q "NOON"
- I $E("MIDNIGHT",1,$L(X))=X Q "MIDNIGHT"
- I (X="AM")!(X="NEXT") Q X_" Lab collection"
- I (X="NEXTA")!(X="CLOSEST") Q $S(X="NEXTA":"NEXT",1:X)_" administration time"
- I $E(D)'="T",$E(D)'="V",($E(D)'="N"!($E(D,1,3)="NOV")) D Q $$FMTE^XLFDT(X,F)
- . N %DT S %DT="TX" D ^%DT S:Y>0 X=Y S:'$G(F) F=1
- S P=$S(D["+":"+",D["-":"-",1:"")
- I P="" S Y=$S($E(D)="T":"TODAY",$E(D)="V":"NEXT VISIT",1:"NOW")
- FTD1 E D
- . N OFFSET,NUM,UNIT
- . S OFFSET=$P(D,P,2),NUM=+OFFSET,UNIT=$E($P(OFFSET,NUM,2)) ; +/-#D
- . I $E(D)="T",NUM=1,UNIT=""!(UNIT="D") S Y=$S(P="+":"TOMORROW",1:"YESTERDAY") Q
- . S Y=NUM_" "_$S(UNIT="'":"MINUTE",UNIT="H":"HOUR",UNIT="W":"WEEK",UNIT="M":"MONTH",1:"DAY")
- . S:NUM>1 Y=Y_"S" ; plural
- . S:$E(D)="N" Y=Y_" "_$S(P="+":"FROM NOW",1:"AGO")
- . S:$E(D)="T" Y=Y_" "_$S(P="+":"FROM TODAY",1:"AGO")
- . S:$E(D)="V" Y=Y_" "_$S(P="+":"AFTER",1:"BEFORE")_" NEXT VISIT"
- I $L(T) S Y=Y_"@"_$$TIME(T)
- Q Y
- ;
- FTDHELP ; -- Displays ??-help for R-type prompts
- G R^ORCDLGH
- Q
- ;
- FTDCOMP(X1,X2,OPER) ; -- Compares free text dates from prompts X1 & X2
- ; Returns 1 or 0, IF $$VAL(X1)<OPER>$$VAL(X2) is true
- N X,Y,Y1,Y2,Z,%DT
- S X=$$VAL(X1),%DT="TX" D ^%DT S Y1=Y ; Y'>0 ??
- S X=$$VAL(X2),%DT="TX" D ^%DT S Y2=Y ; Y'>0 ??
- S Z="I "_Y1_OPER_Y2 X Z
- Q $T
- ;
- TIME(X) ; -- Returns 00:00 PM formatted time
- N Y,Z,%DT
- I X?1U,"BNE"[X Q $S(X="B":"BREAKFAST",X="N":"NOON",X="E":"EVENING",1:"")
- I "NOON"[X Q X
- I "MIDNIGHT"[X Q "MIDNIGHT"
- S X="T@"_X,%DT="TX" D ^%DT I Y'>0 Q ""
- S Z=$$FMTE^XLFDT(Y,"2P"),Z=$P(Z," ",2)_$$UP^XLFSTR($P(Z," ",3))
- Q Z
- ;
- VAL(TEXT,INST) ; -- Returns internal form of TEXT's current value
- N I,X S X="" S:'$G(INST) INST=1
- I '$D(ORDIALOG("B",TEXT)) S I=$O(ORDIALOG("B",TEXT)) Q:$E(I,1,$L(TEXT))'=TEXT X S TEXT=I ; partial match
- S X=$P($G(ORDIALOG("B",TEXT)),U,2) ; ptr
- Q $G(ORDIALOG(X,INST))
- ;
- ORDMSG(OI) ; -- Display order message for orderable OI
- Q:'$O(^ORD(101.43,OI,8,0)) ; no order message
- N I S I=0 W !
- F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 W !,$G(^(I,0))
- W ! Q
- ;
- PTR(NAME) ; -- Returns pointer to Dialog file for prompt NAME
- Q +$O(^ORD(101.41,"AB",$E(NAME,1,63),0))
- ;
- NMSP(PKG) ; -- Returns package namespace from pointer
- N Y S Y=$$GET1^DIQ(9.4,+PKG_",",1)
- S:$E(Y,1,2)="PS" Y="PS" S:Y="GMRV" Y="OR"
- Q Y
- ;
- GETQDLG(QIFN) ; -- define ORDIALOG(PROMPT) for quick order QIFN
- S ORDIALOG=$$DEFDLG(QIFN) Q:'ORDIALOG
- D GETDLG(ORDIALOG),GETORDER("^ORD(101.41,"_QIFN_",6)")
- X:$D(^ORD(101.41,QIFN,3)) ^(3) ; entry action for quick order
- Q
- ;
- DEFDLG(QDLG) ; -- Returns default dialog for QDLG
- N DG,DLG,TOP S DG=+$P($G(^ORD(101.41,+QDLG,0)),U,5)
- S DLG=+$P($G(^ORD(100.98,DG,0)),U,4) ; default dialog
- I 'DLG S TOP=+$O(^ORD(100.98,"AD",DG,0)),DLG=+$P($G(^ORD(100.98,TOP,0)),U,4)
- Q DLG
- ;
- GETDLG(IFN) ; -- define ORDIALOG(PROMPT) for dialog IFN
- N SEQ,DA,ITEM,PTR,PROMPT,TEXT,INDEX,HELP,XHELP,SCREEN,ORD,INPUTXFM,LKP
- S SEQ=0 K ^TMP("ORWORD",$J)
- 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
- . S ITEM=$G(^ORD(101.41,IFN,10,DA,0)),INPUTXFM=$G(^(.1)),HELP=$G(^(1)),SCREEN=$G(^(4)),XHELP=$G(^(6))
- . S PTR=$P(ITEM,U,2),TEXT=$P(ITEM,U,4),INDEX=$P(ITEM,U,10) Q:'PTR
- . S:'$L(TEXT) TEXT=$P(^ORD(101.41,PTR,0),U,2) K ORD
- . S PROMPT=$G(^ORD(101.41,PTR,1)),ORD=DA_U_$P(PROMPT,U,3)
- . S ORD(0)=$P(PROMPT,U)_$S($P(PROMPT,U)="S":"M",1:"")_U_$P(PROMPT,U,2)_$S($L(INPUTXFM):U_INPUTXFM,1:"")
- . S ORD("A")=TEXT S:$L($P(ITEM,U,13)) ORD("TTL")=$P(ITEM,U,13)
- . I $P(ITEM,U,7) S ORD("MAX")=$P(ITEM,U,12),ORD("MORE")=$P(ITEM,U,14) ; fields for multiples
- . 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)
- . S:$L(XHELP) ORD("??")=U_XHELP
- . S:$L(INDEX) ORD("D")=INDEX
- . S:$L(SCREEN) ORD("S")=SCREEN
- . S ORDIALOG("B",$$UP^XLFSTR($P(TEXT,":")))=SEQ_U_PTR
- . M ORDIALOG(PTR)=ORD
- Q
- ;
- GETDLG1(IFN) ; -- basic ORDIALOG(PROMPT) for dialog IFN
- N SEQ,DA,PROMPT,PTR,WINCTRL
- K ^TMP("ORWORD",$J) S SEQ=0
- 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
- . S PTR=$P($G(^ORD(101.41,IFN,10,DA,0)),U,2) Q:'PTR
- . S WINCTRL=$P($G(^ORD(101.41,IFN,10,DA,"W")),U)
- . S PROMPT=$G(^ORD(101.41,PTR,1)) Q:'$L(PROMPT)
- . S ORDIALOG(PTR)=DA_U_$P(PROMPT,U,3)_U_WINCTRL
- . S ORDIALOG(PTR,0)=$P(PROMPT,U,1,2)
- Q
- ;
- GETORDER(ROOT,ARRAY) ; -- retrieve order values from RESPONSES in ARRAY()
- N ORI,ID,PTR,INST,TYPE,DA,X,ORTXT S:'$L($G(ARRAY)) ARRAY="ORDIALOG"
- I +ROOT=ROOT S ROOT="^OR(100,"_ROOT_",4.5)" ; assume Orders file IFN
- S ORI=0 F S ORI=$O(@ROOT@(ORI)) Q:ORI'>0 S ID=$G(@ROOT@(ORI,0)) D
- . S DA=$P(ID,U),PTR=$P(ID,U,2),INST=$P(ID,U,3) S:'INST INST=1
- . S:'PTR PTR=$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) Q:'PTR
- . Q:'$D(ORDIALOG(PTR)) S TYPE=$E($G(ORDIALOG(PTR,0))) Q:'$L(TYPE)
- . I TYPE'="W" S X=$G(@ROOT@(ORI,1)) S:$L(X) @ARRAY@(PTR,INST)=X Q
- . D RESTXT ;resolve objects
- . I ARRAY="ORDIALOG" M ^TMP("ORWORD",$J,PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)="^TMP(""ORWORD"","_$J_","_PTR_","_INST_")"
- . I ARRAY'="ORDIALOG" M @ARRAY@(PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)=$NA(@ARRAY@(PTR,INST))
- . K @ORTXT
- Q
- ;
- RESTXT ; -- resolve objects in text [from GETORDER+8]
- I $$BROKER^XWBLIB!($G(ORTYPE)="Z") M ^TMP("ORX",$J)=@ROOT@(ORI,2) S ORTXT=$NA(^TMP("ORX",$J)) Q ;return text unresolved
- N ARRAY,PTR,INST
- D BLRPLT^TIUSRVD(.ORTXT,,+$G(ORVP),,$NA(@ROOT@(ORI,2)))
- Q
- ;
- DUP(PROMPT,CURRENT) ; -- Compare CURRENT instance of PROMPT for duplicates
- N X,Y,I
- S X=ORDIALOG(PROMPT,CURRENT),Y=0
- 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
- Q Y
- ;
- LIST ; -- Show contents of ORDIALOG(PROMPT,"LIST")
- N NUM S NUM=$G(ORDIALOG(PROMPT,"LIST")) Q:'NUM
- W !,"Choose from"_$S('$P(NUM,U,2):" (or enter another):",1:":")
- LIST1 N I,DONE,CNT S (I,CNT,DONE)=0
- F S I=$O(ORDIALOG(PROMPT,"LIST",I)) Q:I'>0 D Q:DONE
- . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE S DONE=1 Q
- . W !,$J(I,6)_" "_$P(ORDIALOG(PROMPT,"LIST",I),U,2)
- Q
- ;
- SETLIST ; -- Show allowable set of codes
- W !,"Choose from:"
- SETLST1 N I,X F I=1:1:$L(DOMAIN,";") S X=$P(DOMAIN,";",I) I $L(X) D
- . W !,?5,$P(X,":"),?15,$P(X,":",2)
- Q
- ;
- MORE() ; -- show more?
- N X,Y,DIR
- S DIR(0)="EA",DIR("A")=" press <return> to continue or ^ to exit ..."
- D ^DIR
- Q +Y
- ;
- FIRST(P,I) ; -- Returns 1 or 0, if current instance I is first of multiple
- Q '$O(ORDIALOG(P,I),-1)
- ;
- RECALL(P,I) ; -- Returns first value for prompt P, instance I
- N Y S:'$G(I) I=1 S Y=$G(^TMP("ORECALL",$J,+ORDIALOG,P,I))
- Q Y
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCD 8422 printed Jan 18, 2025@03:29:04 Page 2
- ORCD ; SLC/MKB - Order Dialog utilities ;12/15/2006
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,38,68,94,161,141,195,215,243**;Dec 17,1997;Build 242
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- INPT() ; -- Return 1 or 0, if patient/order sheet = inpatient
- +1 NEW Y
- SET Y=$SELECT($GET(ORWARD):1,$GET(^DPT(+ORVP,.105)):1,1:0)
- +2 ;override if delayed order
- IF $GET(OREVENT)
- Begin DoDot:1
- +3 NEW X,X0
- SET X=$$EVT^OREVNTX(+OREVENT)
- SET X0=$GET(^ORD(100.5,+X,0))
- +4 ;use parent
- IF $PIECE(X0,U,12)
- SET X0=$GET(^ORD(100.5,$PIECE(X0,U,12),0))
- +5 ;M/O keep current inpt status
- SET X=$PIECE(X0,U,2)
- if X="M"
- QUIT
- if X="O"
- QUIT
- +6 SET Y=$SELECT(X="A":1,X="T":1,1:0)
- +7 ;From ASIH = Inpt
- IF X="D"
- IF $PIECE(X0,U,7)=41
- SET Y=1
- +8 ;pass = Outpt
- IF X="T"
- IF $PIECE(X0,U,7)
- IF $PIECE(X0,U,7)<4
- SET Y=0
- End DoDot:1
- +9 QUIT Y
- +10 ;
- EXT(P,I,F) ; -- Returns external value of ORDIALOG(Prompt,Instance)
- +1 NEW TYPE,PARAM,FNUM,IENS,X,Y,J,Z
- +2 SET TYPE=$EXTRACT($GET(ORDIALOG(P,0)))
- SET PARAM=$PIECE($GET(ORDIALOG(P,0)),U,2)
- +3 SET X=$GET(ORDIALOG(P,I))
- IF X=""
- QUIT ""
- +4 IF TYPE="N"
- IF X<1
- SET X=0_+X
- IF X="00"
- SET X=0
- +5 IF "FNW"[TYPE
- QUIT X
- +6 IF TYPE="Y"
- QUIT $SELECT(X:"YES",X=0:"NO",1:"")
- +7 IF TYPE="D"
- if '$LENGTH($GET(F))
- SET F=1
- QUIT $$FMTE^XLFDT(X,F)
- +8 ; DAY@TIME
- IF TYPE="R"
- QUIT $$FTDATE(X,$GET(F))
- +9 IF TYPE="P"
- Begin DoDot:1
- +10 SET PARAM=$PIECE(PARAM,":")
- SET FNUM=$SELECT(PARAM:+PARAM,1:+$PIECE(@(U_PARAM_"0)"),U,2))
- +11 SET IENS=+X_","
- SET J=$LENGTH(PARAM,",")
- IF J>2
- FOR
- SET J=J-2
- if J'>0
- QUIT
- SET Z=$PIECE(PARAM,",",J)
- SET IENS=IENS_$SELECT(Z:Z,1:+$PIECE(Z,"(",2))_","
- +12 if '+$GET(F)
- SET F=.01
- SET Y=$$GET1^DIQ(FNUM,IENS,+F)
- +13 IF Y=""
- IF F'=.01
- SET Y=$$GET1^DIQ(FNUM,IENS,.01)
- End DoDot:1
- QUIT Y
- +14 IF TYPE="S"
- FOR J=1:1:$LENGTH(PARAM,";")
- SET Z=$PIECE(PARAM,";",J)
- IF $PIECE(Z,":")=X
- SET Y=$SELECT(+$GET(F):X,1:$PIECE(Z,":",2))
- QUIT
- +15 QUIT $GET(Y)
- +16 ;
- FTDATE(X,F) ; -- Returns free text form of date (i.e. TODAY)
- +1 NEW D,T,P,Y
- IF X=""
- QUIT ""
- +2 ; D=date,T=time parts
- SET X=$$UP^XLFSTR(X)
- SET D=$PIECE(X,"@")
- SET T=$PIECE(X,"@",2)
- +3 IF "NOW"[X
- QUIT "NOW"
- +4 IF "NOON"[X
- QUIT "NOON"
- +5 IF $EXTRACT("MIDNIGHT",1,$LENGTH(X))=X
- QUIT "MIDNIGHT"
- +6 IF (X="AM")!(X="NEXT")
- QUIT X_" Lab collection"
- +7 IF (X="NEXTA")!(X="CLOSEST")
- QUIT $SELECT(X="NEXTA":"NEXT",1:X)_" administration time"
- +8 IF $EXTRACT(D)'="T"
- IF $EXTRACT(D)'="V"
- IF ($EXTRACT(D)'="N"!($EXTRACT(D,1,3)="NOV"))
- Begin DoDot:1
- +9 NEW %DT
- SET %DT="TX"
- DO ^%DT
- if Y>0
- SET X=Y
- if '$GET(F)
- SET F=1
- End DoDot:1
- QUIT $$FMTE^XLFDT(X,F)
- +10 SET P=$SELECT(D["+":"+",D["-":"-",1:"")
- +11 IF P=""
- SET Y=$SELECT($EXTRACT(D)="T":"TODAY",$EXTRACT(D)="V":"NEXT VISIT",1:"NOW")
- FTD1 IF '$TEST
- Begin DoDot:1
- +1 NEW OFFSET,NUM,UNIT
- +2 ; +/-#D
- SET OFFSET=$PIECE(D,P,2)
- SET NUM=+OFFSET
- SET UNIT=$EXTRACT($PIECE(OFFSET,NUM,2))
- +3 IF $EXTRACT(D)="T"
- IF NUM=1
- IF UNIT=""!(UNIT="D")
- SET Y=$SELECT(P="+":"TOMORROW",1:"YESTERDAY")
- QUIT
- +4 SET Y=NUM_" "_$SELECT(UNIT="'":"MINUTE",UNIT="H":"HOUR",UNIT="W":"WEEK",UNIT="M":"MONTH",1:"DAY")
- +5 ; plural
- if NUM>1
- SET Y=Y_"S"
- +6 if $EXTRACT(D)="N"
- SET Y=Y_" "_$SELECT(P="+":"FROM NOW",1:"AGO")
- +7 if $EXTRACT(D)="T"
- SET Y=Y_" "_$SELECT(P="+":"FROM TODAY",1:"AGO")
- +8 if $EXTRACT(D)="V"
- SET Y=Y_" "_$SELECT(P="+":"AFTER",1:"BEFORE")_" NEXT VISIT"
- End DoDot:1
- +9 IF $LENGTH(T)
- SET Y=Y_"@"_$$TIME(T)
- +10 QUIT Y
- +11 ;
- FTDHELP ; -- Displays ??-help for R-type prompts
- +1 GOTO R^ORCDLGH
- +2 QUIT
- +3 ;
- FTDCOMP(X1,X2,OPER) ; -- Compares free text dates from prompts X1 & X2
- +1 ; Returns 1 or 0, IF $$VAL(X1)<OPER>$$VAL(X2) is true
- +2 NEW X,Y,Y1,Y2,Z,%DT
- +3 ; Y'>0 ??
- SET X=$$VAL(X1)
- SET %DT="TX"
- DO ^%DT
- SET Y1=Y
- +4 ; Y'>0 ??
- SET X=$$VAL(X2)
- SET %DT="TX"
- DO ^%DT
- SET Y2=Y
- +5 SET Z="I "_Y1_OPER_Y2
- XECUTE Z
- +6 QUIT $TEST
- +7 ;
- TIME(X) ; -- Returns 00:00 PM formatted time
- +1 NEW Y,Z,%DT
- +2 IF X?1U
- IF "BNE"[X
- QUIT $SELECT(X="B":"BREAKFAST",X="N":"NOON",X="E":"EVENING",1:"")
- +3 IF "NOON"[X
- QUIT X
- +4 IF "MIDNIGHT"[X
- QUIT "MIDNIGHT"
- +5 SET X="T@"_X
- SET %DT="TX"
- DO ^%DT
- IF Y'>0
- QUIT ""
- +6 SET Z=$$FMTE^XLFDT(Y,"2P")
- SET Z=$PIECE(Z," ",2)_$$UP^XLFSTR($PIECE(Z," ",3))
- +7 QUIT Z
- +8 ;
- VAL(TEXT,INST) ; -- Returns internal form of TEXT's current value
- +1 NEW I,X
- SET X=""
- if '$GET(INST)
- SET INST=1
- +2 ; partial match
- IF '$DATA(ORDIALOG("B",TEXT))
- SET I=$ORDER(ORDIALOG("B",TEXT))
- if $EXTRACT(I,1,$LENGTH(TEXT))'=TEXT
- QUIT X
- SET TEXT=I
- +3 ; ptr
- SET X=$PIECE($GET(ORDIALOG("B",TEXT)),U,2)
- +4 QUIT $GET(ORDIALOG(X,INST))
- +5 ;
- ORDMSG(OI) ; -- Display order message for orderable OI
- +1 ; no order message
- if '$ORDER(^ORD(101.43,OI,8,0))
- QUIT
- +2 NEW I
- SET I=0
- WRITE !
- +3 FOR
- SET I=$ORDER(^ORD(101.43,OI,8,I))
- if I'>0
- QUIT
- WRITE !,$GET(^(I,0))
- +4 WRITE !
- QUIT
- +5 ;
- PTR(NAME) ; -- Returns pointer to Dialog file for prompt NAME
- +1 QUIT +$ORDER(^ORD(101.41,"AB",$EXTRACT(NAME,1,63),0))
- +2 ;
- NMSP(PKG) ; -- Returns package namespace from pointer
- +1 NEW Y
- SET Y=$$GET1^DIQ(9.4,+PKG_",",1)
- +2 if $EXTRACT(Y,1,2)="PS"
- SET Y="PS"
- if Y="GMRV"
- SET Y="OR"
- +3 QUIT Y
- +4 ;
- GETQDLG(QIFN) ; -- define ORDIALOG(PROMPT) for quick order QIFN
- +1 SET ORDIALOG=$$DEFDLG(QIFN)
- if 'ORDIALOG
- QUIT
- +2 DO GETDLG(ORDIALOG)
- DO GETORDER("^ORD(101.41,"_QIFN_",6)")
- +3 ; entry action for quick order
- if $DATA(^ORD(101.41,QIFN,3))
- XECUTE ^(3)
- +4 QUIT
- +5 ;
- DEFDLG(QDLG) ; -- Returns default dialog for QDLG
- +1 NEW DG,DLG,TOP
- SET DG=+$PIECE($GET(^ORD(101.41,+QDLG,0)),U,5)
- +2 ; default dialog
- SET DLG=+$PIECE($GET(^ORD(100.98,DG,0)),U,4)
- +3 IF 'DLG
- SET TOP=+$ORDER(^ORD(100.98,"AD",DG,0))
- SET DLG=+$PIECE($GET(^ORD(100.98,TOP,0)),U,4)
- +4 QUIT DLG
- +5 ;
- GETDLG(IFN) ; -- define ORDIALOG(PROMPT) for dialog IFN
- +1 NEW SEQ,DA,ITEM,PTR,PROMPT,TEXT,INDEX,HELP,XHELP,SCREEN,ORD,INPUTXFM,LKP
- +2 SET SEQ=0
- KILL ^TMP("ORWORD",$JOB)
- +3 FOR
- SET SEQ=$ORDER(^ORD(101.41,IFN,10,"B",SEQ))
- if SEQ'>0
- QUIT
- SET DA=0
- FOR
- SET DA=$ORDER(^ORD(101.41,IFN,10,"B",SEQ,DA))
- if 'DA
- QUIT
- Begin DoDot:1
- +4 SET ITEM=$GET(^ORD(101.41,IFN,10,DA,0))
- SET INPUTXFM=$GET(^(.1))
- SET HELP=$GET(^(1))
- SET SCREEN=$GET(^(4))
- SET XHELP=$GET(^(6))
- +5 SET PTR=$PIECE(ITEM,U,2)
- SET TEXT=$PIECE(ITEM,U,4)
- SET INDEX=$PIECE(ITEM,U,10)
- if 'PTR
- QUIT
- +6 if '$LENGTH(TEXT)
- SET TEXT=$PIECE(^ORD(101.41,PTR,0),U,2)
- KILL ORD
- +7 SET PROMPT=$GET(^ORD(101.41,PTR,1))
- SET ORD=DA_U_$PIECE(PROMPT,U,3)
- +8 SET ORD(0)=$PIECE(PROMPT,U)_$SELECT($PIECE(PROMPT,U)="S":"M",1:"")_U_$PIECE(PROMPT,U,2)_$SELECT($LENGTH(INPUTXFM):U_INPUTXFM,1:"")
- +9 SET ORD("A")=TEXT
- if $LENGTH($PIECE(ITEM,U,13))
- SET ORD("TTL")=$PIECE(ITEM,U,13)
- +10 ; fields for multiples
- IF $PIECE(ITEM,U,7)
- SET ORD("MAX")=$PIECE(ITEM,U,12)
- SET ORD("MORE")=$PIECE(ITEM,U,14)
- +11 IF $LENGTH(HELP)
- SET LKP=$PIECE(HELP,U,2)
- SET HELP=$PIECE(HELP,U)
- if $LENGTH(HELP)
- SET ORD("?")=HELP
- if $LENGTH(LKP)
- SET ORD("LKP")=$SELECT($LENGTH(LKP,";")>1:$TRANSLATE(LKP,";","^"),1:U_LKP)
- +12 if $LENGTH(XHELP)
- SET ORD("??")=U_XHELP
- +13 if $LENGTH(INDEX)
- SET ORD("D")=INDEX
- +14 if $LENGTH(SCREEN)
- SET ORD("S")=SCREEN
- +15 SET ORDIALOG("B",$$UP^XLFSTR($PIECE(TEXT,":")))=SEQ_U_PTR
- +16 MERGE ORDIALOG(PTR)=ORD
- End DoDot:1
- +17 QUIT
- +18 ;
- GETDLG1(IFN) ; -- basic ORDIALOG(PROMPT) for dialog IFN
- +1 NEW SEQ,DA,PROMPT,PTR,WINCTRL
- +2 KILL ^TMP("ORWORD",$JOB)
- SET SEQ=0
- +3 FOR
- SET SEQ=$ORDER(^ORD(101.41,IFN,10,"B",SEQ))
- if SEQ'>0
- QUIT
- SET DA=0
- FOR
- SET DA=$ORDER(^ORD(101.41,IFN,10,"B",SEQ,DA))
- if 'DA
- QUIT
- Begin DoDot:1
- +4 SET PTR=$PIECE($GET(^ORD(101.41,IFN,10,DA,0)),U,2)
- if 'PTR
- QUIT
- +5 SET WINCTRL=$PIECE($GET(^ORD(101.41,IFN,10,DA,"W")),U)
- +6 SET PROMPT=$GET(^ORD(101.41,PTR,1))
- if '$LENGTH(PROMPT)
- QUIT
- +7 SET ORDIALOG(PTR)=DA_U_$PIECE(PROMPT,U,3)_U_WINCTRL
- +8 SET ORDIALOG(PTR,0)=$PIECE(PROMPT,U,1,2)
- End DoDot:1
- +9 QUIT
- +10 ;
- GETORDER(ROOT,ARRAY) ; -- retrieve order values from RESPONSES in ARRAY()
- +1 NEW ORI,ID,PTR,INST,TYPE,DA,X,ORTXT
- if '$LENGTH($GET(ARRAY))
- SET ARRAY="ORDIALOG"
- +2 ; assume Orders file IFN
- IF +ROOT=ROOT
- SET ROOT="^OR(100,"_ROOT_",4.5)"
- +3 SET ORI=0
- FOR
- SET ORI=$ORDER(@ROOT@(ORI))
- if ORI'>0
- QUIT
- SET ID=$GET(@ROOT@(ORI,0))
- Begin DoDot:1
- +4 SET DA=$PIECE(ID,U)
- SET PTR=$PIECE(ID,U,2)
- SET INST=$PIECE(ID,U,3)
- if 'INST
- SET INST=1
- +5 if 'PTR
- SET PTR=$PIECE($GET(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2)
- if 'PTR
- QUIT
- +6 if '$DATA(ORDIALOG(PTR))
- QUIT
- SET TYPE=$EXTRACT($GET(ORDIALOG(PTR,0)))
- if '$LENGTH(TYPE)
- QUIT
- +7 IF TYPE'="W"
- SET X=$GET(@ROOT@(ORI,1))
- if $LENGTH(X)
- SET @ARRAY@(PTR,INST)=X
- QUIT
- +8 ;resolve objects
- DO RESTXT
- +9 IF ARRAY="ORDIALOG"
- MERGE ^TMP("ORWORD",$JOB,PTR,INST)=@ORTXT
- SET @ARRAY@(PTR,INST)="^TMP(""ORWORD"","_$JOB_","_PTR_","_INST_")"
- +10 IF ARRAY'="ORDIALOG"
- MERGE @ARRAY@(PTR,INST)=@ORTXT
- SET @ARRAY@(PTR,INST)=$NAME(@ARRAY@(PTR,INST))
- +11 KILL @ORTXT
- End DoDot:1
- +12 QUIT
- +13 ;
- RESTXT ; -- resolve objects in text [from GETORDER+8]
- +1 ;return text unresolved
- IF $$BROKER^XWBLIB!($GET(ORTYPE)="Z")
- MERGE ^TMP("ORX",$JOB)=@ROOT@(ORI,2)
- SET ORTXT=$NAME(^TMP("ORX",$JOB))
- QUIT
- +2 NEW ARRAY,PTR,INST
- +3 DO BLRPLT^TIUSRVD(.ORTXT,,+$GET(ORVP),,$NAME(@ROOT@(ORI,2)))
- +4 QUIT
- +5 ;
- DUP(PROMPT,CURRENT) ; -- Compare CURRENT instance of PROMPT for duplicates
- +1 NEW X,Y,I
- +2 SET X=ORDIALOG(PROMPT,CURRENT)
- SET Y=0
- +3 SET I=0
- FOR
- SET I=$ORDER(ORDIALOG(PROMPT,I))
- if I'>0
- QUIT
- IF I'=CURRENT
- IF $PIECE(ORDIALOG(PROMPT,I),U)=$PIECE(ORDIALOG(PROMPT,CURRENT),U)
- SET Y=1
- QUIT
- +4 QUIT Y
- +5 ;
- LIST ; -- Show contents of ORDIALOG(PROMPT,"LIST")
- +1 NEW NUM
- SET NUM=$GET(ORDIALOG(PROMPT,"LIST"))
- if 'NUM
- QUIT
- +2 WRITE !,"Choose from"_$SELECT('$PIECE(NUM,U,2):" (or enter another):",1:":")
- LIST1 NEW I,DONE,CNT
- SET (I,CNT,DONE)=0
- +1 FOR
- SET I=$ORDER(ORDIALOG(PROMPT,"LIST",I))
- if I'>0
- QUIT
- Begin DoDot:1
- +2 SET CNT=CNT+1
- IF CNT>(IOSL-2)
- SET CNT=0
- IF '$$MORE
- SET DONE=1
- QUIT
- +3 WRITE !,$JUSTIFY(I,6)_" "_$PIECE(ORDIALOG(PROMPT,"LIST",I),U,2)
- End DoDot:1
- if DONE
- QUIT
- +4 QUIT
- +5 ;
- SETLIST ; -- Show allowable set of codes
- +1 WRITE !,"Choose from:"
- SETLST1 NEW I,X
- FOR I=1:1:$LENGTH(DOMAIN,";")
- SET X=$PIECE(DOMAIN,";",I)
- IF $LENGTH(X)
- Begin DoDot:1
- +1 WRITE !,?5,$PIECE(X,":"),?15,$PIECE(X,":",2)
- End DoDot:1
- +2 QUIT
- +3 ;
- MORE() ; -- show more?
- +1 NEW X,Y,DIR
- +2 SET DIR(0)="EA"
- SET DIR("A")=" press <return> to continue or ^ to exit ..."
- +3 DO ^DIR
- +4 QUIT +Y
- +5 ;
- FIRST(P,I) ; -- Returns 1 or 0, if current instance I is first of multiple
- +1 QUIT '$ORDER(ORDIALOG(P,I),-1)
- +2 ;
- RECALL(P,I) ; -- Returns first value for prompt P, instance I
- +1 NEW Y
- if '$GET(I)
- SET I=1
- SET Y=$GET(^TMP("ORECALL",$JOB,+ORDIALOG,P,I))
- +2 QUIT Y