ORCDSD ;SLC/AGP Scheduling Order dialog utilities ;03/19/2019
;;3.0;ORDER ENTRY/RESULTS REPORTING;**434,377**;Dec 17, 1997;Build 582
;Per VHA Directive 6402, this routine should not be modified.
Q
;
INTERH ;
N LIST,NAME
W !,"Select one of the following:"
D INTERL(.LIST)
S NAME="" F S NAME=$O(LIST(NAME)) Q:NAME="" W !," "_NAME
Q
INTERL(LIST) ;
S LIST("WEEKLY")="",LIST("DAILY")=""
Q
;
INTERV ;
N NAME,LIST,TMP
S TMP=$$UP^XLFSTR(X)
D INTERL(.LIST)
I $D(LIST(TMP)) Q
W !!,X_"is an invalid interval",!!
D INTERH
W !
K X
Q
;
PREREQP(ORPAR) ;
N CLSTP,CNT,DIV,ENT,ERR,HFAC,HLOCIEN,ILST,INST,X
S ENT=""
S HLOCIEN=+$G(ORCLOC) I HLOCIEN>0 D
.S DIV=$P($G(^SC(HLOCIEN,0)),U,4)
.S CLSTP=$P($G(^SC(HLOCIEN,0)),U,7)
.S ENT="LOC.`"_HLOCIEN
.I +CLSTP>0 S ENT=ENT_U_"CST.`"_CLSTP
.I +DIV>0 S ENT=ENT_U_"DIV.`"_DIV
S ENT=$S(ENT'="":ENT_U_"SYS",1:"SYS")
D GETLST^XPAR(.ORPAR,ENT,"OR SD DIALOG PREREQ","N",.ERR)
Q
;
PREREQH ;
N CNT,LIST
D PREREQP(.LIST)
I '$D(LIST) W !,"No prerequisites defined"
W !,"Select from the following:"
S CNT=0 F S CNT=$O(LIST(CNT)) Q:CNT'>0 D
.I $P(LIST(CNT),U)="" Q
.W !," "_$P(LIST(CNT),U)
Q
;
PREREQN() ;
N LIST,NUM
D PREREQP(.LIST)
I '$D(LIST) Q 0
S NUM=LIST
Q NUM
;
PREREQV ;
N ARRAY,CNT,NODE,LIST,TMP
S TMP=$$UP^XLFSTR(X)
D PREREQP(.LIST)
S CNT=0 F S CNT=$O(LIST(CNT)) Q:CNT'>0 D
.I $P(LIST(CNT),U)="" Q
.S ARRAY($$UP^XLFSTR($P(LIST(CNT),U)))=""
I '$D(ARRAY(TMP)) W !,X_" is not a valid prerequisite" K X Q
I $G(X)="" W !! D PREREQH
Q
;
SETSTOP() ;
N %DT,CIDC,RESULT,OFFSET,X,Y
S RESULT="T"
S X=$$VAL^ORCD("CLINICALLY")
S %DT="T" D ^%DT
S OFFSET=$$GET^XPAR("SYS","OR SD CIDC STOP OFFSET",1,"E")
I Y>0 S RESULT=$$FMADD^XLFDT(Y,OFFSET)
Q RESULT
;
VALCLINC(Y) ;
;N IEN
;S IEN=$O(^SC("B",X,"")) I IEN'>0 Q 0
I ("C"'[$P($G(^SC(Y,0)),U,3)!('$$ACTLOC^ORWU(Y))) Q 0
Q 1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCDSD 1941 printed Dec 13, 2024@02:28:15 Page 2
ORCDSD ;SLC/AGP Scheduling Order dialog utilities ;03/19/2019
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**434,377**;Dec 17, 1997;Build 582
+2 ;Per VHA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
INTERH ;
+1 NEW LIST,NAME
+2 WRITE !,"Select one of the following:"
+3 DO INTERL(.LIST)
+4 SET NAME=""
FOR
SET NAME=$ORDER(LIST(NAME))
if NAME=""
QUIT
WRITE !," "_NAME
+5 QUIT
INTERL(LIST) ;
+1 SET LIST("WEEKLY")=""
SET LIST("DAILY")=""
+2 QUIT
+3 ;
INTERV ;
+1 NEW NAME,LIST,TMP
+2 SET TMP=$$UP^XLFSTR(X)
+3 DO INTERL(.LIST)
+4 IF $DATA(LIST(TMP))
QUIT
+5 WRITE !!,X_"is an invalid interval",!!
+6 DO INTERH
+7 WRITE !
+8 KILL X
+9 QUIT
+10 ;
PREREQP(ORPAR) ;
+1 NEW CLSTP,CNT,DIV,ENT,ERR,HFAC,HLOCIEN,ILST,INST,X
+2 SET ENT=""
+3 SET HLOCIEN=+$GET(ORCLOC)
IF HLOCIEN>0
Begin DoDot:1
+4 SET DIV=$PIECE($GET(^SC(HLOCIEN,0)),U,4)
+5 SET CLSTP=$PIECE($GET(^SC(HLOCIEN,0)),U,7)
+6 SET ENT="LOC.`"_HLOCIEN
+7 IF +CLSTP>0
SET ENT=ENT_U_"CST.`"_CLSTP
+8 IF +DIV>0
SET ENT=ENT_U_"DIV.`"_DIV
End DoDot:1
+9 SET ENT=$SELECT(ENT'="":ENT_U_"SYS",1:"SYS")
+10 DO GETLST^XPAR(.ORPAR,ENT,"OR SD DIALOG PREREQ","N",.ERR)
+11 QUIT
+12 ;
PREREQH ;
+1 NEW CNT,LIST
+2 DO PREREQP(.LIST)
+3 IF '$DATA(LIST)
WRITE !,"No prerequisites defined"
+4 WRITE !,"Select from the following:"
+5 SET CNT=0
FOR
SET CNT=$ORDER(LIST(CNT))
if CNT'>0
QUIT
Begin DoDot:1
+6 IF $PIECE(LIST(CNT),U)=""
QUIT
+7 WRITE !," "_$PIECE(LIST(CNT),U)
End DoDot:1
+8 QUIT
+9 ;
PREREQN() ;
+1 NEW LIST,NUM
+2 DO PREREQP(.LIST)
+3 IF '$DATA(LIST)
QUIT 0
+4 SET NUM=LIST
+5 QUIT NUM
+6 ;
PREREQV ;
+1 NEW ARRAY,CNT,NODE,LIST,TMP
+2 SET TMP=$$UP^XLFSTR(X)
+3 DO PREREQP(.LIST)
+4 SET CNT=0
FOR
SET CNT=$ORDER(LIST(CNT))
if CNT'>0
QUIT
Begin DoDot:1
+5 IF $PIECE(LIST(CNT),U)=""
QUIT
+6 SET ARRAY($$UP^XLFSTR($PIECE(LIST(CNT),U)))=""
End DoDot:1
+7 IF '$DATA(ARRAY(TMP))
WRITE !,X_" is not a valid prerequisite"
KILL X
QUIT
+8 IF $GET(X)=""
WRITE !!
DO PREREQH
+9 QUIT
+10 ;
SETSTOP() ;
+1 NEW %DT,CIDC,RESULT,OFFSET,X,Y
+2 SET RESULT="T"
+3 SET X=$$VAL^ORCD("CLINICALLY")
+4 SET %DT="T"
DO ^%DT
+5 SET OFFSET=$$GET^XPAR("SYS","OR SD CIDC STOP OFFSET",1,"E")
+6 IF Y>0
SET RESULT=$$FMADD^XLFDT(Y,OFFSET)
+7 QUIT RESULT
+8 ;
VALCLINC(Y) ;
+1 ;N IEN
+2 ;S IEN=$O(^SC("B",X,"")) I IEN'>0 Q 0
+3 IF ("C"'[$PIECE($GET(^SC(Y,0)),U,3)!('$$ACTLOC^ORWU(Y)))
QUIT 0
+4 QUIT 1
+5 ;
