ORCXPND1 ; SLC/MKB - Expanded Display cont ; 04/25/2007
;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,67,75,89,92,94,148,159,188,172,215,243**;Dec 17, 1997;Build 242
;
; External References
; DBIA 2387 ^LAB(60
; DBIA 3420 ^DPT( file #2
; DBIA 10035 ^DPT( file #2
; DBIA 10037 EN^DGRPD
; DBIA 700 DIS^DGRPDB
; DBIA 2926 RT^GMRCGUIA
; DBIA 2925 DT^GMRCSLM2 ^TMP("GMRCR"
; DBIA 2503 RR^LR7OR1 ^TMP("LRRR"
; DBIA 2951 EN1^LR7OSBR ^TMP("LRC"
; DBIA 2952 EN^LR7OSMZ0
; DBIA 2400 OEL^PSOORRL ^TMP("PS"
; DBIA 2877 EN3^RAO7PC3
; DBIA 2877 EN30^RAO7PC3
; DBIA 1252 $$OUTPTPR^SDUTL3
; DBIA 1252 $$OUTPTTM^SDUTL3
; DBIA 2832 RPC^TIUSRV
; DBIA 10061 DEM^VADPT
; DBIA 10061 KVAR^VADPT
; DBIA 10061 OAD^VADPT
; DBIA 10103 $$FMTE^XLFDT
; DBIA 4408 DISP^DGIBDSP
;
COVER ; -- Cover Sheet
N PKG S PKG=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4)
D ALLERGY^ORCXPND2:PKG="GMRA",NOTES:PKG="TIU"
Q
NOTES ; -- Progress Notes
N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J)
D RPC^TIUSRV(.ORY,ID)
S I=0 F S I=$O(@ORY@(I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0))
K @ORY
Q
PROBLEMS ; -- Problem List
D PL^ORCXPND4
Q
MEDS ; -- Pharmacy
;N NODE,ORIFN
K ^TMP("PS",$J)
D OEL^PSOORRL(+ORVP,ID) ;S NODE=$G(^TMP("PS",$J,0)),ORIFN=+$P(NODE,U,11)
S ID=+$P($G(^TMP("PS",$J,0)),U,11) D ORDERS ;DBIA 2400
;D @($S($P($G(^OR(100,ORIFN,0)),U,11)=$O(^ORD(100.98,"B","IV RX",0)):"IV",1:"DRUG")_"^ORCXPND2")
K ^TMP("PS",$J)
Q
LABS ; -- Laboratory [RESULTS ONLY for ID=OE order #]
N ORIFN,X,SUB,TEST,NAME,SS,IDE,IVDT,TST,CCNT,ORCY,IG,TCNT
K ^TMP("LRRR",$J) ;DBIA 2503
I (ID?2.5U1" "2N1" "1.N1"-"7N1"."1.4N)!(ID?2.5U1" "2N1" "1.N1"-"7N) D AP^ORCXPND3 Q ;ID=Accession #-Date/time specimen taken
S ORIFN=+ID,IDE=$G(^OR(100,+ID,4)) Q:'$L(IDE) ; OE# -> Lab#
I +IDE D RR^LR7OR1(+ORVP,IDE) I '$D(^TMP("LRRR",$J,+ORVP)) S $P(IDE,";",1,3)=";;" ;Order possibly purged, reset to lookup on file 63
I '+IDE,$P(IDE,";",5) D RR^LR7OR1(+ORVP,,9999999-$P(IDE,";",5),9999999-$P(IDE,";",5),$P(IDE,";",4))
K ORCY D TEXT^ORQ12(.ORCY,ORIFN,80)
S IG=0 F S IG=$O(ORCY(IG)) Q:IG<1 S X=ORCY(IG) D ITEM^ORCXPND(X)
D BLANK^ORCXPND I '$D(^TMP("LRRR",$J,+ORVP)) S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q
M TEST=^TMP("LRRR",$J,+ORVP) S CCNT=0,SS=""
F S SS=$O(TEST(SS)) Q:SS="" S IVDT=0 F S IVDT=$O(TEST(SS,IVDT)) Q:'IVDT D
. I SS="BB" D
.. I $$GET^XPAR("DIV^SYS^PKG","OR VBECS ON",1,"Q"),$L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D Q ;Transition to VBEC's interface
... K ^TMP("ORLRC",$J)
... D EN^ORWLR1(DFN)
... I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..."
... N I S I=0 F S I=$O(^TMP("ORLRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X
... K ^TMP("ORLRC",$J)
.. K ^TMP("LRC",$J) D EN1^LR7OSBR(+ORVP) Q:'$D(^TMP("LRC",$J)) D Q ;DBIA 2951
... N I S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X
... K ^TMP("LRC",$J)
. I SS="MI" K ^TMP("LRC",$J) D EN^LR7OSMZ0(+ORVP) Q:'$D(^TMP("LRC",$J)) D Q
.. N I S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X
.. K ^TMP("LRC",$J)
. I SS="CH" D Q
.. S (TCNT,TST)=0 F S TST=$O(TEST(SS,IVDT,TST)) Q:TST="" S CCNT=0,TCNT=TCNT+1 D
... I TCNT=1 D
.... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" Collection time: "_$$FMTE^XLFDT(9999999-IVDT,1)
.... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT," ")_$$S(3,CCNT,"Test Name")_$$S(29,CCNT,"Result")_$$S(39,CCNT,"Units")_$$S(55,CCNT,"Range") D:$D(IOUON) SETVIDEO^ORCXPND(LCNT,1,70,IOUON,IOUOFF)
... I TST S X=TEST(SS,IVDT,TST),CCNT=0 I +X D
.... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT,$P(^LAB(60,+X,0),U))_$$S(26,CCNT,$J($P(X,U,2),7))_$$S(34,CCNT,$S($L($P(X,U,3)):$P(X,U,3),1:""))_$$S(39,CCNT,$P(X,U,4))_$$S(45,CCNT,$J($P(X,U,5),15))
.... I $L($P(X,U,3)),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOINHI,IOINORM)
.... I $P(X,U,3)["*",$D(IOBON),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOBON_IOINHI,IOBOFF_IOINORM)
... I TST="N" S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" Comments: " D
.... N CMT S CMT=0 F S CMT=$O(TEST(SS,IVDT,"N",CMT)) Q:'CMT S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" "_TEST(SS,IVDT,"N",CMT)
K ^TMP("LRRR",$J)
Q
;
DELAY ; -- Delayed Orders
NEW ; -- New Orders
ORDERS ; -- Orders
I '$G(ORESULTS) D ORDERS^ORCXPND2 Q
; -- Results Display (Add more packages as available)
N PKG,TAB,ORIFN
S PKG=+$P($G(^OR(100,+ID,0)),"^",14),PKG=$$NMSP^ORCD(PKG)
S TAB=$S(PKG="LR":"LABS",PKG="GMRC":"CONSULTS",PKG="RA":"XRAYS",1:"")
I '$L(TAB)!(ID'>0) D Q ; no display available
. N ORY,I D TEXT^ORQ12(.ORY,+ID,80)
. S I=0 F S I=$O(ORY(I)) Q:I'>0 D ITEM^ORCXPND(ORY(I))
. D BLANK^ORCXPND
. S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="There are no results to report."
I $O(^OR(100,+ID,2,0)) S ORIFN=+ID,ID=0 F S ID=$O(^OR(100,ORIFN,2,ID)) Q:ID<1 I $D(^OR(100,ID,0)) D @TAB
I '$O(^OR(100,+ID,2,0)) D @TAB
Q
REPORTS ; -- Patient Profiles
D EN^ORCXPNDR ; Reports
Q
CONSULTS ; -- Consults
N I,X,SUB,ORTX ;,VALMAR
I $G(ORTAB)="CONSULTS" S X=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4)
E D TEXT^ORQ12(.ORTX,+ID) S X=ORTX(1),ID=+$G(^OR(100,+ID,4)) ; OE->GMRC order#
D ITEM^ORCXPND(X),BLANK^ORCXPND
I ID'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q
I '$G(ORESULTS) D ;DT action
. S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Consult No.: "_ID
. N GMRCOER S GMRCOER=2 D DT^GMRCSLM2(ID) S SUB="DT" ;DBIA 2925
I $G(ORESULTS) D RT^GMRCGUIA(ID,"^TMP(""GMRCR"",$J,""RT"")") S SUB="RT"
S I=0 F S I=$O(^TMP("GMRCR",$J,SUB,I)) Q:I'>0 S X=$G(^(I,0)),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;DBIA 2925
K ^TMP("GMRCR",$J)
Q
XRAYS ; -- Radiology
I '$G(ORESULTS) S ID=+ORVP_U_$TR(ID,"-","^") D EN3^RAO7PC3(ID)
I $G(ORESULTS) S ID=+$G(^OR(100,+ID,4)) D EN30^RAO7PC3(ID)
N CASE,PROC,PSET S PSET=$D(^TMP($J,"RAE3",+ORVP,"PRINT_SET"))
S CASE=0 F S CASE=$O(^TMP($J,"RAE3",+ORVP,CASE)) Q:CASE'>0 D
. I PSET S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,"")) D ITEM^ORCXPND(PROC) Q
. S PROC="" F S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC)) Q:PROC="" D ITEM^ORCXPND(PROC),BLANK^ORCXPND,XRPT,BLANK^ORCXPND
I PSET S CASE=$O(^TMP($J,"RAE3",+ORVP,0)),PROC=$O(^(CASE,"")) D BLANK^ORCXPND,XRPT,BLANK^ORCXPND ;printset=list all procs, then one report
K ^TMP($J,"RAE3",+ORVP),^UTILITY($J,"W")
S VALM("RM")=81
Q
;
XRPT ; -- Body of Report for CASE, PROC
N ORD,X,I
S ORD=$S($L($G(^TMP($J,"RAE3",+ORVP,"ORD"))):^("ORD"),$L($G(^("ORD",CASE))):^(CASE),1:"") I $L(ORD),ORD'=PROC S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Proc Ord: "_ORD
S I=1 F S I=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC,I)) Q:I'>0 S X=^(I),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;Skip pt ID on line 1
Q
;
SUMMRIES ; -- Discharge Summaries
N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J)
D RPC^TIUSRV(.ORY,ID)
S I=0 F S I=$O(@ORY@(I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0))
K @ORY
Q
PTINQ ; Print Patient Inquiry in List Manager
N DFN,ORI,X
S DFN=+ORVP
D DGINQ(DFN)
S ORI=4,LCNT=0
F S ORI=$O(^TMP("ORDATA",$J,1,ORI)) Q:'ORI S X=^(ORI) D
. S LCNT=LCNT+1
. S ^TMP("ORXPND",$J,LCNT,0)=X
K ^TMP("ORDATA",$J,1)
Q
;
DGINQ(DFN) ; Patient Inquiry
D START^ORWRP(80,"DGINQB^ORCXPND1(DFN)")
Q
DGINQB(DFN) ; Build Patient Inquiry
N CONTACT,ORDOC,ORTEAM,ORVP,XQORNOD,ORSSTRT,ORSSTOPT,VAOA
S ORVP=DFN_";DPT(",XQORNOD=1
D EN^DGRPD ; MAS Patient Inquiry
;
S ORDOC=$$OUTPTPR^SDUTL3(DFN)
S ORTEAM=$$OUTPTTM^SDUTL3(DFN)
I ORDOC!ORTEAM D
. W !!,"Primary Care Information:"
. I ORDOC W !,"Primary Practitioner: ",$P(ORDOC,"^",2)
. I ORTEAM W !,"Primary Care Team: ",$P(ORTEAM,"^",2)
W !!,"Health Insurance Information:"
D DISP^DGIBDSP ;DBIA #4408
W !!,"Service Connection/Rated Disabilities:"
D DIS^DGRPDB
F CONTACT="N","S" D
.S VAOA("A")=$S(CONTACT="N":"",1:3)
.D OAD^VADPT ; Get NOK Information
.I VAOA(9)]"" D
.. W !!,$S(CONTACT="N":"Next of Kin Information:",1:"Secondary Next of Kin Information:")
.. W !,"Name: ",VAOA(9) ; NOK Name
.. I VAOA(10)]"" W " (",VAOA(10),")" ; Relationship
.. I VAOA(1)]"" W !?7,VAOA(1) ; Address Line 1
.. I VAOA(2)]"" W !?7,VAOA(2) ; Line 2
.. I VAOA(3)]"" W !?7,VAOA(3) ; Line 3
.. I VAOA(4)]"" D
.. . W !?7,VAOA(4) ; City
.. . I VAOA(5)]"" W ", "_$P(VAOA(5),"^",2) ; State
.. . W " ",$P(VAOA(11),"^",2) ; Zip+4
.. I VAOA(8)]"" W !!?7,"Phone number: ",VAOA(8) ; Phone
.. I CONTACT="N",$P($G(^DPT(DFN,.21)),U,11)]"" W !?7,"Work phone number: ",$P(^DPT(DFN,.21),U,11)
.. I CONTACT="S",$P($G(^DPT(DFN,.211)),U,11)]"" W !?7,"Work phone number: ",$P(^DPT(DFN,.211),U,11)
D KVAR^VADPT
Q
TRIM(X) ; Trim Spaces
S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
Q X
S(X,Y,Z) ; Pad Over
; X=Column #
; Y=Current Length
; Z=Text
; SP=Text Sent
; CCNT=Line Position After Input Text
I '$D(Z) Q ""
N SP S SP=Z I X,Y,X>Y S SP=$E(" ",1,X-Y)_Z
S CCNT=$$INC(CCNT,SP)
Q SP
INC(X,Y) ; Character Position Count
; X=Current Count
; Y=Text
N INC S INC=X+$L(Y)
Q INC
ORCXPND1 ; SLC/MKB - Expanded Display cont ; 04/25/2007
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,67,75,89,92,94,148,159,188,172,215,243**;Dec 17, 1997;Build 242
+2 ;
+3 ; External References
+4 ; DBIA 2387 ^LAB(60
+5 ; DBIA 3420 ^DPT( file #2
+6 ; DBIA 10035 ^DPT( file #2
+7 ; DBIA 10037 EN^DGRPD
+8 ; DBIA 700 DIS^DGRPDB
+9 ; DBIA 2926 RT^GMRCGUIA
+10 ; DBIA 2925 DT^GMRCSLM2 ^TMP("GMRCR"
+11 ; DBIA 2503 RR^LR7OR1 ^TMP("LRRR"
+12 ; DBIA 2951 EN1^LR7OSBR ^TMP("LRC"
+13 ; DBIA 2952 EN^LR7OSMZ0
+14 ; DBIA 2400 OEL^PSOORRL ^TMP("PS"
+15 ; DBIA 2877 EN3^RAO7PC3
+16 ; DBIA 2877 EN30^RAO7PC3
+17 ; DBIA 1252 $$OUTPTPR^SDUTL3
+18 ; DBIA 1252 $$OUTPTTM^SDUTL3
+19 ; DBIA 2832 RPC^TIUSRV
+20 ; DBIA 10061 DEM^VADPT
+21 ; DBIA 10061 KVAR^VADPT
+22 ; DBIA 10061 OAD^VADPT
+23 ; DBIA 10103 $$FMTE^XLFDT
+24 ; DBIA 4408 DISP^DGIBDSP
+25 ;
COVER ; -- Cover Sheet
+1 NEW PKG
SET PKG=$PIECE($GET(^TMP("OR",$JOB,ORTAB,"IDX",NUM)),U,4)
+2 IF PKG="GMRA"
DO ALLERGY^ORCXPND2
IF PKG="TIU"
DO NOTES
+3 QUIT
NOTES ; -- Progress Notes
+1 NEW I,ORY,DATE,AUTHOR,PTLOC,SUBJ
KILL ^TMP("TIUAUDIT",$JOB)
+2 DO RPC^TIUSRV(.ORY,ID)
+3 SET I=0
FOR
SET I=$ORDER(@ORY@(I))
IF I'>0
QUIT
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)=$GET(@ORY@(I,0))
+4 KILL @ORY
+5 QUIT
PROBLEMS ; -- Problem List
+1 DO PL^ORCXPND4
+2 QUIT
MEDS ; -- Pharmacy
+1 ;N NODE,ORIFN
+2 KILL ^TMP("PS",$JOB)
+3 ;S NODE=$G(^TMP("PS",$J,0)),ORIFN=+$P(NODE,U,11)
DO OEL^PSOORRL(+ORVP,ID)
+4 ;DBIA 2400
SET ID=+$PIECE($GET(^TMP("PS",$JOB,0)),U,11)
DO ORDERS
+5 ;D @($S($P($G(^OR(100,ORIFN,0)),U,11)=$O(^ORD(100.98,"B","IV RX",0)):"IV",1:"DRUG")_"^ORCXPND2")
+6 KILL ^TMP("PS",$JOB)
+7 QUIT
LABS ; -- Laboratory [RESULTS ONLY for ID=OE order #]
+1 NEW ORIFN,X,SUB,TEST,NAME,SS,IDE,IVDT,TST,CCNT,ORCY,IG,TCNT
+2 ;DBIA 2503
KILL ^TMP("LRRR",$JOB)
+3 ;ID=Accession #-Date/time specimen taken
IF (ID?2.5U1" "2N1" "1.N1"-"7N1"."1.4N)!(ID?2.5U1" "2N1" "1.N1"-"7N)
DO AP^ORCXPND3
QUIT
+4 ; OE# -> Lab#
SET ORIFN=+ID
SET IDE=$GET(^OR(100,+ID,4))
IF '$LENGTH(IDE)
QUIT
+5 ;Order possibly purged, reset to lookup on file 63
IF +IDE
DO RR^LR7OR1(+ORVP,IDE)
IF '$DATA(^TMP("LRRR",$JOB,+ORVP))
SET $PIECE(IDE,";",1,3)=";;"
+6 IF '+IDE
IF $PIECE(IDE,";",5)
DO RR^LR7OR1(+ORVP,,9999999-$PIECE(IDE,";",5),9999999-$PIECE(IDE,";",5),$PIECE(IDE,";",4))
+7 KILL ORCY
DO TEXT^ORQ12(.ORCY,ORIFN,80)
+8 SET IG=0
FOR
SET IG=$ORDER(ORCY(IG))
IF IG<1
QUIT
SET X=ORCY(IG)
DO ITEM^ORCXPND(X)
+9 DO BLANK^ORCXPND
IF '$DATA(^TMP("LRRR",$JOB,+ORVP))
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)="No data available."
QUIT
+10 MERGE TEST=^TMP("LRRR",$JOB,+ORVP)
SET CCNT=0
SET SS=""
+11 FOR
SET SS=$ORDER(TEST(SS))
IF SS=""
QUIT
SET IVDT=0
FOR
SET IVDT=$ORDER(TEST(SS,IVDT))
IF 'IVDT
QUIT
Begin DoDot:1
+12 IF SS="BB"
Begin DoDot:2
+13 ;Transition to VBEC's interface
IF $$GET^XPAR("DIV^SYS^PKG","OR VBECS ON",1,"Q")
IF $LENGTH($TEXT(EN^ORWLR1))
IF $LENGTH($TEXT(CPRS^VBECA3B))
Begin DoDot:3
+14 KILL ^TMP("ORLRC",$JOB)
+15 DO EN^ORWLR1(DFN)
+16 IF '$ORDER(^TMP("ORLRC",$JOB,0))
SET ^TMP("ORLRC",$JOB,1,0)=""
SET ^TMP("ORLRC",$JOB,2,0)="No Blood Bank report available..."
+17 NEW I
SET I=0
FOR
SET I=$ORDER(^TMP("ORLRC",$JOB,I))
IF I<1
QUIT
SET X=^(I,0)
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)=X
+18 KILL ^TMP("ORLRC",$JOB)
End DoDot:3
QUIT
+19 ;DBIA 2951
KILL ^TMP("LRC",$JOB)
DO EN1^LR7OSBR(+ORVP)
IF '$DATA(^TMP("LRC",$JOB))
QUIT
Begin DoDot:3
+20 NEW I
SET I=0
FOR
SET I=$ORDER(^TMP("LRC",$JOB,I))
IF I<1
QUIT
SET X=^(I,0)
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)=X
+21 KILL ^TMP("LRC",$JOB)
End DoDot:3
QUIT
End DoDot:2
+22 IF SS="MI"
KILL ^TMP("LRC",$JOB)
DO EN^LR7OSMZ0(+ORVP)
IF '$DATA(^TMP("LRC",$JOB))
QUIT
Begin DoDot:2
+23 NEW I
SET I=0
FOR
SET I=$ORDER(^TMP("LRC",$JOB,I))
IF I<1
QUIT
SET X=^(I,0)
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)=X
+24 KILL ^TMP("LRC",$JOB)
End DoDot:2
QUIT
+25 IF SS="CH"
Begin DoDot:2
+26 SET (TCNT,TST)=0
FOR
SET TST=$ORDER(TEST(SS,IVDT,TST))
IF TST=""
QUIT
SET CCNT=0
SET TCNT=TCNT+1
Begin DoDot:3
+27 IF TCNT=1
Begin DoDot:4
+28 SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)=" Collection time: "_$$FMTE^XLFDT(9999999-IVDT,1)
+29 SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)=$$S(1,CCNT," ")_$$S(3,CCNT,"Test Name")_$$S(29,CCNT,"Result")_$$S(39,CCNT,"Units")_$$S(55,CCNT,"Range")
IF $DATA(IOUON)
DO SETVIDEO^ORCXPND(LCNT,1,70,IOUON,IOUOFF)
End DoDot:4
+30 IF TST
SET X=TEST(SS,IVDT,TST)
SET CCNT=0
IF +X
Begin DoDot:4
+31 SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)=$$S(1,CCNT,$PIECE(^LAB(60,+X,0),U))_$$S(26,CCNT,$JUSTIFY($PIECE(X,U,2),7))_$$S(34,CCNT,$SELECT($LENGTH($PIECE(X,U,3)):$PIECE(X,U,3),1:""))_$$S(39,CCNT,$PIECE(X,U,4))_$$S(45,
CCNT,$JUSTIFY($PIECE(X,U,5),15))
+32 IF $LENGTH($PIECE(X,U,3))
IF $DATA(IOINHI)
DO SETVIDEO^ORCXPND(LCNT,26,8,IOINHI,IOINORM)
+33 IF $PIECE(X,U,3)["*"
IF $DATA(IOBON)
IF $DATA(IOINHI)
DO SETVIDEO^ORCXPND(LCNT,26,8,IOBON_IOINHI,IOBOFF_IOINORM)
End DoDot:4
+34 IF TST="N"
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)=" Comments: "
Begin DoDot:4
+35 NEW CMT
SET CMT=0
FOR
SET CMT=$ORDER(TEST(SS,IVDT,"N",CMT))
IF 'CMT
QUIT
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)=" "_TEST(SS,IVDT,"N",CMT)
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+36 KILL ^TMP("LRRR",$JOB)
+37 QUIT
+38 ;
DELAY ; -- Delayed Orders
NEW ; -- New Orders
ORDERS ; -- Orders
+1 IF '$GET(ORESULTS)
DO ORDERS^ORCXPND2
QUIT
+2 ; -- Results Display (Add more packages as available)
+3 NEW PKG,TAB,ORIFN
+4 SET PKG=+$PIECE($GET(^OR(100,+ID,0)),"^",14)
SET PKG=$$NMSP^ORCD(PKG)
+5 SET TAB=$SELECT(PKG="LR":"LABS",PKG="GMRC":"CONSULTS",PKG="RA":"XRAYS",1:"")
+6 ; no display available
IF '$LENGTH(TAB)!(ID'>0)
Begin DoDot:1
+7 NEW ORY,I
DO TEXT^ORQ12(.ORY,+ID,80)
+8 SET I=0
FOR
SET I=$ORDER(ORY(I))
IF I'>0
QUIT
DO ITEM^ORCXPND(ORY(I))
+9 DO BLANK^ORCXPND
+10 SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)="There are no results to report."
End DoDot:1
QUIT
+11 IF $ORDER(^OR(100,+ID,2,0))
SET ORIFN=+ID
SET ID=0
FOR
SET ID=$ORDER(^OR(100,ORIFN,2,ID))
IF ID<1
QUIT
IF $DATA(^OR(100,ID,0))
DO @TAB
+12 IF '$ORDER(^OR(100,+ID,2,0))
DO @TAB
+13 QUIT
REPORTS ; -- Patient Profiles
+1 ; Reports
DO EN^ORCXPNDR
+2 QUIT
CONSULTS ; -- Consults
+1 ;,VALMAR
NEW I,X,SUB,ORTX
+2 IF $GET(ORTAB)="CONSULTS"
SET X=$PIECE($GET(^TMP("OR",$JOB,ORTAB,"IDX",NUM)),U,4)
+3 ; OE->GMRC order#
IF '$TEST
DO TEXT^ORQ12(.ORTX,+ID)
SET X=ORTX(1)
SET ID=+$GET(^OR(100,+ID,4))
+4 DO ITEM^ORCXPND(X)
DO BLANK^ORCXPND
+5 IF ID'>0
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)="No data available."
QUIT
+6 ;DT action
IF '$GET(ORESULTS)
Begin DoDot:1
+7 SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)="Consult No.: "_ID
+8 ;DBIA 2925
NEW GMRCOER
SET GMRCOER=2
DO DT^GMRCSLM2(ID)
SET SUB="DT"
End DoDot:1
+9 IF $GET(ORESULTS)
DO RT^GMRCGUIA(ID,"^TMP(""GMRCR"",$J,""RT"")")
SET SUB="RT"
+10 ;DBIA 2925
SET I=0
FOR
SET I=$ORDER(^TMP("GMRCR",$JOB,SUB,I))
IF I'>0
QUIT
SET X=$GET(^(I,0))
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)=X
+11 KILL ^TMP("GMRCR",$JOB)
+12 QUIT
XRAYS ; -- Radiology
+1 IF '$GET(ORESULTS)
SET ID=+ORVP_U_$TRANSLATE(ID,"-","^")
DO EN3^RAO7PC3(ID)
+2 IF $GET(ORESULTS)
SET ID=+$GET(^OR(100,+ID,4))
DO EN30^RAO7PC3(ID)
+3 NEW CASE,PROC,PSET
SET PSET=$DATA(^TMP($JOB,"RAE3",+ORVP,"PRINT_SET"))
+4 SET CASE=0
FOR
SET CASE=$ORDER(^TMP($JOB,"RAE3",+ORVP,CASE))
IF CASE'>0
QUIT
Begin DoDot:1
+5 IF PSET
SET PROC=$ORDER(^TMP($JOB,"RAE3",+ORVP,CASE,""))
DO ITEM^ORCXPND(PROC)
QUIT
+6 SET PROC=""
FOR
SET PROC=$ORDER(^TMP($JOB,"RAE3",+ORVP,CASE,PROC))
IF PROC=""
QUIT
DO ITEM^ORCXPND(PROC)
DO BLANK^ORCXPND
DO XRPT
DO BLANK^ORCXPND
End DoDot:1
+7 ;printset=list all procs, then one report
IF PSET
SET CASE=$ORDER(^TMP($JOB,"RAE3",+ORVP,0))
SET PROC=$ORDER(^(CASE,""))
DO BLANK^ORCXPND
DO XRPT
DO BLANK^ORCXPND
+8 KILL ^TMP($JOB,"RAE3",+ORVP),^UTILITY($JOB,"W")
+9 SET VALM("RM")=81
+10 QUIT
+11 ;
XRPT ; -- Body of Report for CASE, PROC
+1 NEW ORD,X,I
+2 SET ORD=$SELECT($LENGTH($GET(^TMP($JOB,"RAE3",+ORVP,"ORD"))):^("ORD"),$LENGTH($GET(^("ORD",CASE))):^(CASE),1:"")
IF $LENGTH(ORD)
IF ORD'=PROC
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)="Proc Ord: "_ORD
+3 ;Skip pt ID on line 1
SET I=1
FOR
SET I=$ORDER(^TMP($JOB,"RAE3",+ORVP,CASE,PROC,I))
IF I'>0
QUIT
SET X=^(I)
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)=X
+4 QUIT
+5 ;
SUMMRIES ; -- Discharge Summaries
+1 NEW I,ORY,DATE,AUTHOR,PTLOC,SUBJ
KILL ^TMP("TIUAUDIT",$JOB)
+2 DO RPC^TIUSRV(.ORY,ID)
+3 SET I=0
FOR
SET I=$ORDER(@ORY@(I))
IF I'>0
QUIT
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)=$GET(@ORY@(I,0))
+4 KILL @ORY
+5 QUIT
PTINQ ; Print Patient Inquiry in List Manager
+1 NEW DFN,ORI,X
+2 SET DFN=+ORVP
+3 DO DGINQ(DFN)
+4 SET ORI=4
SET LCNT=0
+5 FOR
SET ORI=$ORDER(^TMP("ORDATA",$JOB,1,ORI))
IF 'ORI
QUIT
SET X=^(ORI)
Begin DoDot:1
+6 SET LCNT=LCNT+1
+7 SET ^TMP("ORXPND",$JOB,LCNT,0)=X
End DoDot:1
+8 KILL ^TMP("ORDATA",$JOB,1)
+9 QUIT
+10 ;
DGINQ(DFN) ; Patient Inquiry
+1 DO START^ORWRP(80,"DGINQB^ORCXPND1(DFN)")
+2 QUIT
DGINQB(DFN) ; Build Patient Inquiry
+1 NEW CONTACT,ORDOC,ORTEAM,ORVP,XQORNOD,ORSSTRT,ORSSTOPT,VAOA
+2 SET ORVP=DFN_";DPT("
SET XQORNOD=1
+3 ; MAS Patient Inquiry
DO EN^DGRPD
+4 ;
+5 SET ORDOC=$$OUTPTPR^SDUTL3(DFN)
+6 SET ORTEAM=$$OUTPTTM^SDUTL3(DFN)
+7 IF ORDOC!ORTEAM
Begin DoDot:1
+8 WRITE !!,"Primary Care Information:"
+9 IF ORDOC
WRITE !,"Primary Practitioner: ",$PIECE(ORDOC,"^",2)
+10 IF ORTEAM
WRITE !,"Primary Care Team: ",$PIECE(ORTEAM,"^",2)
End DoDot:1
+11 WRITE !!,"Health Insurance Information:"
+12 ;DBIA #4408
DO DISP^DGIBDSP
+13 WRITE !!,"Service Connection/Rated Disabilities:"
+14 DO DIS^DGRPDB
+15 FOR CONTACT="N","S"
Begin DoDot:1
+16 SET VAOA("A")=$SELECT(CONTACT="N":"",1:3)
+17 ; Get NOK Information
DO OAD^VADPT
+18 IF VAOA(9)]""
Begin DoDot:2
+19 WRITE !!,$SELECT(CONTACT="N":"Next of Kin Information:",1:"Secondary Next of Kin Information:")
+20 ; NOK Name
WRITE !,"Name: ",VAOA(9)
+21 ; Relationship
IF VAOA(10)]""
WRITE " (",VAOA(10),")"
+22 ; Address Line 1
IF VAOA(1)]""
WRITE !?7,VAOA(1)
+23 ; Line 2
IF VAOA(2)]""
WRITE !?7,VAOA(2)
+24 ; Line 3
IF VAOA(3)]""
WRITE !?7,VAOA(3)
+25 IF VAOA(4)]""
Begin DoDot:3
+26 ; City
WRITE !?7,VAOA(4)
+27 ; State
IF VAOA(5)]""
WRITE ", "_$PIECE(VAOA(5),"^",2)
+28 ; Zip+4
WRITE " ",$PIECE(VAOA(11),"^",2)
End DoDot:3
+29 ; Phone
IF VAOA(8)]""
WRITE !!?7,"Phone number: ",VAOA(8)
+30 IF CONTACT="N"
IF $PIECE($GET(^DPT(DFN,.21)),U,11)]""
WRITE !?7,"Work phone number: ",$PIECE(^DPT(DFN,.21),U,11)
+31 IF CONTACT="S"
IF $PIECE($GET(^DPT(DFN,.211)),U,11)]""
WRITE !?7,"Work phone number: ",$PIECE(^DPT(DFN,.211),U,11)
End DoDot:2
End DoDot:1
+32 DO KVAR^VADPT
+33 QUIT
TRIM(X) ; Trim Spaces
+1 SET X=$GET(X)
FOR
IF $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
IF $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 QUIT X
S(X,Y,Z) ; Pad Over
+1 ; X=Column #
+2 ; Y=Current Length
+3 ; Z=Text
+4 ; SP=Text Sent
+5 ; CCNT=Line Position After Input Text
+6 IF '$DATA(Z)
QUIT ""
+7 NEW SP
SET SP=Z
IF X
IF Y
IF X>Y
SET SP=$EXTRACT(" ",1,X-Y)_Z
+8 SET CCNT=$$INC(CCNT,SP)
+9 QUIT SP
INC(X,Y) ; Character Position Count
+1 ; X=Current Count
+2 ; Y=Text
+3 NEW INC
SET INC=X+$LENGTH(Y)
+4 QUIT INC
