- ORCHTAB ;SLC/MKB-Build Chart tab listings ;05:58 PM 23 Aug 2000
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,72,68,94**;Dec 17, 1997
- EN ; -- rebuild ORTAB listing
- N CONTEXT,DEFCXT,LCNT,NUM,ORTITLE,ORCAPTN,ORMENU,ORACTNS,ORCHANGE,Z,ORMAX,ORRM
- S CONTEXT=$S($P($G(^TMP("OR",$J,ORTAB,0)),U,4):"",1:$P($G(^(0)),U,3))
- S (LCNT,NUM)=0,ORMAX=40 K ^TMP("OR",$J,ORTAB)
- D EN^ORCHTAB1 ; rebuild ORTAB via CONTEXT
- I 'LCNT S LCNT=1,^TMP("OR",$J,ORTAB,1,0)=" "_$$PAD("No data available.",40)_"|"
- S ^TMP("OR",$J,ORTAB,0)=LCNT_U_NUM_U_CONTEXT_U_$G(DEFCXT),^("TITLE")=$G(ORTITLE),^("RM")=$S($G(ORRM):ORRM,1:240)
- I $D(ORCHANGE) S Z=$O(^ORD(101,"B",ORCHANGE,0)) S:Z ^TMP("OR",$J,ORTAB,"CHANGE")=Z_";ORD(101,"
- I $D(ORACTNS),NUM S Z=$O(^ORD(101,"B",ORACTNS,0)) S:Z ^TMP("OR",$J,ORTAB,"#")=Z_"^1:"_NUM
- I $D(ORMENU) S Z=$O(^ORD(101,"B",ORMENU,0)) S:Z ^TMP("OR",$J,ORTAB,"MENU")=Z_";ORD(101,"
- I $D(ORCAPTN) M ^TMP("OR",$J,ORTAB,"CAPTION")=ORCAPTN
- Q
- ;
- SUBHDR(X) ; -- add subheader X to listing
- S LCNT=LCNT+1,^TMP("OR",$J,ORTAB,LCNT,0)=" "_$$PAD(X,40)_"|"
- D SETVIDEO(LCNT,6,$L(X),IOUON,IOUOFF)
- S ^TMP("OR",$J,ORTAB,"HDR",X)=LCNT
- Q
- ;
- ADD ; -- add item to listing
- N FIRST,LINES,I
- S LCNT=LCNT+1,NUM=NUM+1,FIRST=LCNT,LINES=+$G(ORTX)
- S:+$G(DATA)>LINES LINES=+DATA
- S ^TMP("OR",$J,ORTAB,"IDX",NUM)=ID_U_FIRST_U_LINES_U_$G(ORIFN)
- S ^TMP("OR",$J,ORTAB,LCNT,0)=$$PAD(NUM,5)_$$PAD($G(ORTX(1)),40)_"| "_$G(DATA(1))
- F I=2:1:LINES S LCNT=LCNT+1,^TMP("OR",$J,ORTAB,LCNT,0)=" "_$$PAD($G(ORTX(I)),40)_"| "_$G(DATA(I))
- D:$L(ID) SETVIDEO(FIRST,1,5,IOINHI,IOINORM) ; hilite selectable items
- K ORTX
- Q
- ;
- LINE ; -- add line X with DATA to listing
- S LCNT=LCNT+1,^TMP("OR",$J,ORTAB,LCNT,0)=" "_$$PAD(X,40)_"| "_$G(DATA)
- Q
- ;
- BLANK ; -- add blank line
- S LCNT=LCNT+1,^TMP("OR",$J,ORTAB,LCNT,0)=$$REPEAT^XLFSTR(" ",45)_"|"
- Q
- ;
- SETVIDEO(LINE,COL,WIDTH,ON,OFF) ; -- set video attributes
- S ^TMP("OR",$J,ORTAB,"VIDEO",LINE,COL,WIDTH)=ON
- S ^TMP("OR",$J,ORTAB,"VIDEO",LINE,COL+WIDTH,0)=OFF
- Q
- ;
- PAD(X,WIDTH) ; -- returns X padded with spaces to total WIDTH
- N Y S Y=X_$$REPEAT^XLFSTR(" ",WIDTH-$L(X))
- Q Y
- ;
- DATE(X) ;
- N D,Y S D=$P(X,".") I D="" Q ""
- I 'D Q $E($$FTDATE^ORCD(D),1,8) ; free text date
- S Y=$E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
- Q Y
- ;
- DATETIME(X,LF) ;
- N D,T,Y,YR,TM I X="" Q ""
- I X'>0 S X=$$FTDT(X) Q:X'?7N.1".".6N X ;free text date/time
- S D=$P(X,"."),T=$P(X,".",2) I D="" Q ""
- S Y=$E(D,4,5)_"/"_$E(D,6,7),YR=1700+$E(D,1,3),TM=""
- I T S:$L(T)<4 T=T_$E("0000",1,4-$L(T)) S TM=$E(T,1,2)_":"_$E(T,3,4)
- I '$G(LF) S Y=Y_"/"_$E(YR,3,4)_$S(T:" "_TM,1:"") ;not Order Long Format
- E S Y=Y_$S(X'<($$NOW^XLFDT-10000):" "_TM,LF=1:" "_YR,1:"/"_$E(YR,3,4))
- Q Y
- ;
- FTDT(X) ; -- Return free text date for use in Tab displays
- N Y,%DT S X=$$UP^XLFSTR(X)
- Q:"NOW"[X "NOW" I X?1"NOW+"1.N.E Q X
- I "NOON"[X Q "NOON"
- I $E("MIDNIGHT",1,$L(X))[X Q "MIDNIGHT"
- I (X="AM")!(X="NEXT")!(X="CLOSEST") Q X
- I X="NEXTA" Q "NEXT"
- I $E(X)="T" D Q Y
- . N X1,X2 S X1=$P(X,"@"),X2=$P(X,"@",2)
- . S Y=$S(X1="T":"TODAY",1:X1)_" "_X2
- S %DT="TX" D ^%DT
- Q Y
- ;
- LNAMEF(X) ; -- Returns user X name as LNAME,F
- N LN,FN,Y S X=$P($G(^VA(200,+X,0)),U) Q:X="" "UNKNOWN"
- S LN=$P(X,","),FN=$P(X,",",2) S:$E(FN)=" " FN=$E(FN,2,99)
- S Y=$E(LN,1,8)_","_$E(FN)
- Q Y
- ;
- TXT ; -- Add text in X to ORTX() up to ORMAX width
- N I,Y S:'$G(ORTX) ORTX=1,ORTX(1)="" S Y=$L(ORTX(ORTX))
- I $L(ORTX(ORTX)_" "_X)'>ORMAX S ORTX(ORTX)=ORTX(ORTX)_$S(Y:" ",1:"")_X Q
- F I=1:1:$L(X," ") S:$L(ORTX(ORTX)_" "_$P(X," ",I))>ORMAX ORTX=ORTX+1,Y=0 S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_$P(X," ",I),Y=1
- Q
- ;
- ACCESS() ; -- Does user have menu tree access to CPRS?
- I '$L($T(ACCESS^XQCHK)) Q 1 ;Can't check - allow access
- N OROK,ORTYP,OROPT S OROK=0
- F ORTYP="WARD CLERK","NURSE","CLINICIAN" D Q:OROK
- . S OROPT=+$$FIND1^DIC(19,"","QX","OR OE/RR MENU "_ORTYP) Q:OROPT'>0
- . S:$$ACCESS^XQCHK(DUZ,OROPT)>0 OROK=1
- Q OROK
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCHTAB 3962 printed Feb 18, 2025@23:54:59 Page 2
- ORCHTAB ;SLC/MKB-Build Chart tab listings ;05:58 PM 23 Aug 2000
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,72,68,94**;Dec 17, 1997
- EN ; -- rebuild ORTAB listing
- +1 NEW CONTEXT,DEFCXT,LCNT,NUM,ORTITLE,ORCAPTN,ORMENU,ORACTNS,ORCHANGE,Z,ORMAX,ORRM
- +2 SET CONTEXT=$SELECT($PIECE($GET(^TMP("OR",$JOB,ORTAB,0)),U,4):"",1:$PIECE($GET(^(0)),U,3))
- +3 SET (LCNT,NUM)=0
- SET ORMAX=40
- KILL ^TMP("OR",$JOB,ORTAB)
- +4 ; rebuild ORTAB via CONTEXT
- DO EN^ORCHTAB1
- +5 IF 'LCNT
- SET LCNT=1
- SET ^TMP("OR",$JOB,ORTAB,1,0)=" "_$$PAD("No data available.",40)_"|"
- +6 SET ^TMP("OR",$JOB,ORTAB,0)=LCNT_U_NUM_U_CONTEXT_U_$GET(DEFCXT)
- SET ^("TITLE")=$GET(ORTITLE)
- SET ^("RM")=$SELECT($GET(ORRM):ORRM,1:240)
- +7 IF $DATA(ORCHANGE)
- SET Z=$ORDER(^ORD(101,"B",ORCHANGE,0))
- if Z
- SET ^TMP("OR",$JOB,ORTAB,"CHANGE")=Z_";ORD(101,"
- +8 IF $DATA(ORACTNS)
- IF NUM
- SET Z=$ORDER(^ORD(101,"B",ORACTNS,0))
- if Z
- SET ^TMP("OR",$JOB,ORTAB,"#")=Z_"^1:"_NUM
- +9 IF $DATA(ORMENU)
- SET Z=$ORDER(^ORD(101,"B",ORMENU,0))
- if Z
- SET ^TMP("OR",$JOB,ORTAB,"MENU")=Z_";ORD(101,"
- +10 IF $DATA(ORCAPTN)
- MERGE ^TMP("OR",$JOB,ORTAB,"CAPTION")=ORCAPTN
- +11 QUIT
- +12 ;
- SUBHDR(X) ; -- add subheader X to listing
- +1 SET LCNT=LCNT+1
- SET ^TMP("OR",$JOB,ORTAB,LCNT,0)=" "_$$PAD(X,40)_"|"
- +2 DO SETVIDEO(LCNT,6,$LENGTH(X),IOUON,IOUOFF)
- +3 SET ^TMP("OR",$JOB,ORTAB,"HDR",X)=LCNT
- +4 QUIT
- +5 ;
- ADD ; -- add item to listing
- +1 NEW FIRST,LINES,I
- +2 SET LCNT=LCNT+1
- SET NUM=NUM+1
- SET FIRST=LCNT
- SET LINES=+$GET(ORTX)
- +3 if +$GET(DATA)>LINES
- SET LINES=+DATA
- +4 SET ^TMP("OR",$JOB,ORTAB,"IDX",NUM)=ID_U_FIRST_U_LINES_U_$GET(ORIFN)
- +5 SET ^TMP("OR",$JOB,ORTAB,LCNT,0)=$$PAD(NUM,5)_$$PAD($GET(ORTX(1)),40)_"| "_$GET(DATA(1))
- +6 FOR I=2:1:LINES
- SET LCNT=LCNT+1
- SET ^TMP("OR",$JOB,ORTAB,LCNT,0)=" "_$$PAD($GET(ORTX(I)),40)_"| "_$GET(DATA(I))
- +7 ; hilite selectable items
- if $LENGTH(ID)
- DO SETVIDEO(FIRST,1,5,IOINHI,IOINORM)
- +8 KILL ORTX
- +9 QUIT
- +10 ;
- LINE ; -- add line X with DATA to listing
- +1 SET LCNT=LCNT+1
- SET ^TMP("OR",$JOB,ORTAB,LCNT,0)=" "_$$PAD(X,40)_"| "_$GET(DATA)
- +2 QUIT
- +3 ;
- BLANK ; -- add blank line
- +1 SET LCNT=LCNT+1
- SET ^TMP("OR",$JOB,ORTAB,LCNT,0)=$$REPEAT^XLFSTR(" ",45)_"|"
- +2 QUIT
- +3 ;
- SETVIDEO(LINE,COL,WIDTH,ON,OFF) ; -- set video attributes
- +1 SET ^TMP("OR",$JOB,ORTAB,"VIDEO",LINE,COL,WIDTH)=ON
- +2 SET ^TMP("OR",$JOB,ORTAB,"VIDEO",LINE,COL+WIDTH,0)=OFF
- +3 QUIT
- +4 ;
- PAD(X,WIDTH) ; -- returns X padded with spaces to total WIDTH
- +1 NEW Y
- SET Y=X_$$REPEAT^XLFSTR(" ",WIDTH-$LENGTH(X))
- +2 QUIT Y
- +3 ;
- DATE(X) ;
- +1 NEW D,Y
- SET D=$PIECE(X,".")
- IF D=""
- QUIT ""
- +2 ; free text date
- IF 'D
- QUIT $EXTRACT($$FTDATE^ORCD(D),1,8)
- +3 SET Y=$EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
- +4 QUIT Y
- +5 ;
- DATETIME(X,LF) ;
- +1 NEW D,T,Y,YR,TM
- IF X=""
- QUIT ""
- +2 ;free text date/time
- IF X'>0
- SET X=$$FTDT(X)
- if X'?7N.1".".6N
- QUIT X
- +3 SET D=$PIECE(X,".")
- SET T=$PIECE(X,".",2)
- IF D=""
- QUIT ""
- +4 SET Y=$EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)
- SET YR=1700+$EXTRACT(D,1,3)
- SET TM=""
- +5 IF T
- if $LENGTH(T)<4
- SET T=T_$EXTRACT("0000",1,4-$LENGTH(T))
- SET TM=$EXTRACT(T,1,2)_":"_$EXTRACT(T,3,4)
- +6 ;not Order Long Format
- IF '$GET(LF)
- SET Y=Y_"/"_$EXTRACT(YR,3,4)_$SELECT(T:" "_TM,1:"")
- +7 IF '$TEST
- SET Y=Y_$SELECT(X'<($$NOW^XLFDT-10000):" "_TM,LF=1:" "_YR,1:"/"_$EXTRACT(YR,3,4))
- +8 QUIT Y
- +9 ;
- FTDT(X) ; -- Return free text date for use in Tab displays
- +1 NEW Y,%DT
- SET X=$$UP^XLFSTR(X)
- +2 if "NOW"[X
- QUIT "NOW"
- IF X?1"NOW+"1.N.E
- QUIT X
- +3 IF "NOON"[X
- QUIT "NOON"
- +4 IF $EXTRACT("MIDNIGHT",1,$LENGTH(X))[X
- QUIT "MIDNIGHT"
- +5 IF (X="AM")!(X="NEXT")!(X="CLOSEST")
- QUIT X
- +6 IF X="NEXTA"
- QUIT "NEXT"
- +7 IF $EXTRACT(X)="T"
- Begin DoDot:1
- +8 NEW X1,X2
- SET X1=$PIECE(X,"@")
- SET X2=$PIECE(X,"@",2)
- +9 SET Y=$SELECT(X1="T":"TODAY",1:X1)_" "_X2
- End DoDot:1
- QUIT Y
- +10 SET %DT="TX"
- DO ^%DT
- +11 QUIT Y
- +12 ;
- LNAMEF(X) ; -- Returns user X name as LNAME,F
- +1 NEW LN,FN,Y
- SET X=$PIECE($GET(^VA(200,+X,0)),U)
- if X=""
- QUIT "UNKNOWN"
- +2 SET LN=$PIECE(X,",")
- SET FN=$PIECE(X,",",2)
- if $EXTRACT(FN)=" "
- SET FN=$EXTRACT(FN,2,99)
- +3 SET Y=$EXTRACT(LN,1,8)_","_$EXTRACT(FN)
- +4 QUIT Y
- +5 ;
- TXT ; -- Add text in X to ORTX() up to ORMAX width
- +1 NEW I,Y
- if '$GET(ORTX)
- SET ORTX=1
- SET ORTX(1)=""
- SET Y=$LENGTH(ORTX(ORTX))
- +2 IF $LENGTH(ORTX(ORTX)_" "_X)'>ORMAX
- SET ORTX(ORTX)=ORTX(ORTX)_$SELECT(Y:" ",1:"")_X
- QUIT
- +3 FOR I=1:1:$LENGTH(X," ")
- if $LENGTH(ORTX(ORTX)_" "_$PIECE(X," ",I))>ORMAX
- SET ORTX=ORTX+1
- SET Y=0
- SET ORTX(ORTX)=$GET(ORTX(ORTX))_$SELECT(Y:" ",1:"")_$PIECE(X," ",I)
- SET Y=1
- +4 QUIT
- +5 ;
- ACCESS() ; -- Does user have menu tree access to CPRS?
- +1 ;Can't check - allow access
- IF '$LENGTH($TEXT(ACCESS^XQCHK))
- QUIT 1
- +2 NEW OROK,ORTYP,OROPT
- SET OROK=0
- +3 FOR ORTYP="WARD CLERK","NURSE","CLINICIAN"
- Begin DoDot:1
- +4 SET OROPT=+$$FIND1^DIC(19,"","QX","OR OE/RR MENU "_ORTYP)
- if OROPT'>0
- QUIT
- +5 if $$ACCESS^XQCHK(DUZ,OROPT)>0
- SET OROK=1
- End DoDot:1
- if OROK
- QUIT
- +6 QUIT OROK