ORCXPND1 ; SLC/MKB - Expanded Display cont ;May 3, 2021@21:00
;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,67,75,89,92,94,148,159,188,172,215,243,280,340,306,350,423,514,527,539,513,585**;Dec 17, 1997;Build 2
;
; 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 1252 $$OUTPTAP^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
; DBIA 5697 START^SCMCMHTC
; DBIA 7104 EXT^DGENU
; DBIA 4192 EXTCAT^DGENA4 and CATEGORY^DGENA4
; DBIA 3812 FINDCUR^DGENA and GET^DGENA
; DBIA 3880 CPRS^VBECA3B
; DBIA 7203 EN^VBECRPT
; DBIA 7249 GET^VAFCREL
;
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,XT
K ^TMP("LRRR",$J) ;DBIA 2503
S ORIFN=+ID,IDE=$G(^OR(100,+ID,4)) Q:'$L(IDE) ; OE# -> Lab#
I $G(DFN),$P(IDE,";",4)?1(1"SP",1"CY",1"EM") N XQADATA S XQADATA=$P(IDE,";",4)_U_U_$P(IDE,";",5) D AP^ORCXPND3 Q ;coversheet and orders result display
I $P(IDE,";",5) D RR^LR7OR1(+ORVP,,9999999-$P(IDE,";",5),9999999-$P(IDE,";",5),$P(IDE,";",4)) ;lookup on file 63 first
I '$P(IDE,";",5),+IDE D RR^LR7OR1(+ORVP,IDE) I '$D(^TMP("LRRR",$J,+ORVP)) S $P(IDE,";",1,3)=";;"
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) ;RLM
... D EN^VBECRPT ;RLM
... 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 LINE="Collection time: "_$$FMTE^XLFDT(9999999-IVDT,"M")
.... D SETLINE(LINE,.LCNT)
.... D BLANK^ORCXPND
.... S LINE=$$S(1,CCNT," ")_$$S(2,CCNT,"Test Name")_$$S(38,CCNT,"Result")_$$S(48,CCNT,"Units")_$$S(64,CCNT,"Range")
.... D SETLINE(LINE,.LCNT)
.... S CCNT=0,LINE=$$S(1,CCNT," ")_$$S(2,CCNT,"---------")_$$S(38,CCNT,"------")_$$S(48,CCNT,"-----")_$$S(64,CCNT,"-----")
.... D SETLINE(LINE,.LCNT)
.... D:$D(IOUON) SETVIDEO^ORCXPND(LCNT,1,70,IOUON,IOUOFF)
... I TST S XT=TEST(SS,IVDT,TST),CCNT=0 I +XT D
.... S NAME=$S($L($P(^LAB(60,+XT,0),U))>25:$S($L($P($G(^(.1)),U)):$P(^(.1),U),1:$E($P(^(0),U),1,25)),1:$E($P(^(0),U),1,25))
.... ;OR*3.0*585: Adjusted spacing in line below - $$S(24... instead of $$S(25...
.... ; and add " " before $$S(31
.... S LINE=$$S(1,CCNT,NAME)_$$S(24,CCNT,$J($P(XT,U,2),20))_" "_$$S(31,CCNT,$S($L($P(XT,U,3)):$P(XT,U,3),1:""))_$$S(48,CCNT,$P(XT,U,4))_$$S(58,CCNT,$J($P(XT,U,5),15))
.... D SETLINE(LINE,.LCNT)
.... I $P(XT,U,20) S ^TMP("ORPLS",$J,$P(XT,U,20))=""
.... I $L($P(XT,U,3)),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOINHI,IOINORM)
.... I $P(XT,U,3)["*",$D(IOBON),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOBON_IOINHI,IOBOFF_IOINORM)
... I TST="N" S LINE=" Comments: " D
.... D SETLINE(LINE,.LCNT)
.... N CMT S CMT=0 F S CMT=$O(TEST(SS,IVDT,"N",CMT)) Q:'CMT S LINE=" "_TEST(SS,IVDT,"N",CMT) D SETLINE(LINE,.LCNT)
I $L($O(^TMP("ORPLS",$J,""))) D SETLINE(" ",.LCNT),SETLINE(" ",.LCNT),SETLINE("===============================================================================",.LCNT),PLS
D SETLINE(" ",.LCNT)
K ^TMP("LRRR",$J)
Q
;
PLS ; List performing laboratories
N LINE,ORPLS,X
D SETLINE("Performing Lab Sites",.LCNT)
S ORPLS=0
F S ORPLS=$O(^TMP("ORPLS",$J,ORPLS)) Q:ORPLS<1 D
. S LINE=$$LJ^XLFSTR("["_ORPLS_"] ",8)_$$NAME^XUAF4(ORPLS)
. D SETLINE(LINE,.LCNT)
. S X=$$PADD^XUAF4(ORPLS)
. S LINE=$$REPEAT^XLFSTR(" ",8)_$P(X,U)_" "_$P(X,U,2)_", "_$P(X,U,3)_" "_$P(X,U,4)
. D SETLINE(LINE,.LCNT)
D SETLINE("===============================================================================",.LCNT)
K ^TMP("ORPLS",$J)
Q
;
SETLINE(LINE,CNT) ;
S CNT=CNT+1,^TMP("ORXPND",$J,CNT,0)=LINE
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,ORMHP,ORVP,XQORNOD,ORSSTRT,ORSSTOPT,VAOA,CPRSGUI,ORINP,ORATP,ORASS,ORENRI,ORENRD,ORENC,ORESG,A
S ORVP=DFN_";DPT(",XQORNOD=1,CPRSGUI=1
D EN^DGRPD ; MAS Patient Inquiry
I $$GET^XPAR("ALL","ORWPT SHOW CAREGIVER") D
. W !!,"Caregiver Information:"
. N ORRET,ORRETS,ORPRIM,ORSEC,ORGEN,ORA,ORD
. W ! D GET^VAFCREL(.ORRET,DFN)
. I $P(ORRET(0),"^")=-1 W "Caregiver information not currently available: ",$P(ORRET(0),"^",2),! Q
. I $P(ORRET(0),"^")=0 W "No Caregiver information returned." Q
. S ORRETS=0,ORPRIM="",ORSEC="",ORGEN=""
. F S ORRETS=$O(ORRET(ORRETS)) Q:'ORRETS D
.. S ORA=$G(ORRET(ORRETS)) I ORA="" Q
.. I $P(ORA,"^",2)="CGP",$P(ORA,"^",5)="ACTIVE" S ORD("PRIM",ORRETS)=$P(ORA,"^",8) Q
.. I $P(ORA,"^",2)="CGS",$P(ORA,"^",5)="ACTIVE" S ORD("SEC",ORRETS)=$P(ORA,"^",8) Q
.. I $P(ORA,"^",2)="CGG",$P(ORA,"^",5)="ACTIVE" S ORD("GEN",ORRETS)=$P(ORA,"^",8)
.. Q
. I $D(ORD("PRIM")) D
.. W ?5,"Primary Caregiver: "
.. S ORRETS=0
.. F S ORRETS=$O(ORD("PRIM",ORRETS)) Q:'ORRETS W ?24,ORD("PRIM",ORRETS),!
.. W !
. I $D(ORD("SEC")) D
.. W ?3,"Secondary Caregiver: "
.. S ORRETS=0
.. F S ORRETS=$O(ORD("SEC",ORRETS)) Q:'ORRETS W ?24,ORD("SEC",ORRETS),!
.. W !
. I $D(ORD("GEN")) D
.. W ?5,"General Caregiver: "
.. S ORRETS=0
.. F S ORRETS=$O(ORD("GEN",ORRETS)) Q:'ORRETS W ?24,ORD("GEN",ORRETS),!
S ORENRI=$$FINDCUR^DGENA(DFN),A=$$GET^DGENA(ORENRI,.ORENRD),ORENC=$$CATEGORY^DGENA4(DFN),ORESG=$S($G(ORENRD("SUBGRP"))]"":$$EXT^DGENU("SUBGRP",ORENRD("SUBGRP")),1:"")
W !!!,"Enrollment Priority: ",$S($G(ORENRD("PRIORITY"))]"":"GROUP "_$G(ORENRD("PRIORITY")),1:"")_ORESG,?40,"Category: ",$$EXTCAT^DGENA4(ORENC),!!
K CPRSGUI
;
S ORDOC=$$OUTPTPR^SDUTL3(DFN)
S ORTEAM=$$OUTPTTM^SDUTL3(DFN)
S ORMHP=$$START^SCMCMHTC(DFN) ;Retrieve Mental Health Provider
S ORINP=$G(^DPT(DFN,.104))
S ORATP=$G(^DPT(DFN,.1041))
S ORASS=$P($$OUTPTAP^SDUTL3(DFN,DT),U,2)
I ORDOC!ORTEAM!ORMHP!ORINP!ORATP D
. W !!,"Primary Care Information:"
. I ORDOC W !,"Primary Practitioner: ",$P(ORDOC,"^",2)
. I ORTEAM W !,"Primary Care Team: ",$P(ORTEAM,"^",2)
. I $$INPT^ORWPT1(DFN) D
. . I ORATP W !,"Attending Physician: ",$P($G(^VA(200,+ORATP,0)),U)
. . I ORINP W !,"Inpatient Provider: ",$P($G(^VA(200,+ORINP,0)),U)
. I $L(ORASS) W !,"Associate Provider: ",ORASS
. I ORMHP D
.. W !!,"MH Treatment Information:"
.. W !,"MH Treatment Coord: ",$E($P(ORMHP,"^",2),1,28) D
... W ?52,"Position: ",$E($P(ORMHP,"^",3),1,18)
.. W !,"MH Treatment Team: ",$E($P(ORMHP,"^",5),1,56)
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCXPND1 13504 printed Sep 23, 2025@20:05:25 Page 2
ORCXPND1 ; SLC/MKB - Expanded Display cont ;May 3, 2021@21:00
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,67,75,89,92,94,148,159,188,172,215,243,280,340,306,350,423,514,527,539,513,585**;Dec 17, 1997;Build 2
+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 1252 $$OUTPTAP^SDUTL3
+20 ; DBIA 2832 RPC^TIUSRV
+21 ; DBIA 10061 DEM^VADPT
+22 ; DBIA 10061 KVAR^VADPT
+23 ; DBIA 10061 OAD^VADPT
+24 ; DBIA 10103 $$FMTE^XLFDT
+25 ; DBIA 4408 DISP^DGIBDSP
+26 ; DBIA 5697 START^SCMCMHTC
+27 ; DBIA 7104 EXT^DGENU
+28 ; DBIA 4192 EXTCAT^DGENA4 and CATEGORY^DGENA4
+29 ; DBIA 3812 FINDCUR^DGENA and GET^DGENA
+30 ; DBIA 3880 CPRS^VBECA3B
+31 ; DBIA 7203 EN^VBECRPT
+32 ; DBIA 7249 GET^VAFCREL
+33 ;
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,XT
+2 ;DBIA 2503
KILL ^TMP("LRRR",$JOB)
+3 ; OE# -> Lab#
SET ORIFN=+ID
SET IDE=$GET(^OR(100,+ID,4))
if '$LENGTH(IDE)
QUIT
+4 ;coversheet and orders result display
IF $GET(DFN)
IF $PIECE(IDE,";",4)?1(1"SP",1"CY",1"EM")
NEW XQADATA
SET XQADATA=$PIECE(IDE,";",4)_U_U_$PIECE(IDE,";",5)
DO AP^ORCXPND3
QUIT
+5 ;lookup on file 63 first
IF $PIECE(IDE,";",5)
DO RR^LR7OR1(+ORVP,,9999999-$PIECE(IDE,";",5),9999999-$PIECE(IDE,";",5),$PIECE(IDE,";",4))
+6 IF '$PIECE(IDE,";",5)
IF +IDE
DO RR^LR7OR1(+ORVP,IDE)
IF '$DATA(^TMP("LRRR",$JOB,+ORVP))
SET $PIECE(IDE,";",1,3)=";;"
+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 ;D EN^ORWLR1(DFN) ;RLM
+16 ;RLM
DO EN^VBECRPT
+17 IF '$ORDER(^TMP("ORLRC",$JOB,0))
SET ^TMP("ORLRC",$JOB,1,0)=""
SET ^TMP("ORLRC",$JOB,2,0)="No Blood Bank report available..."
+18 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
+19 KILL ^TMP("ORLRC",$JOB)
End DoDot:3
QUIT
+20 ;DBIA 2951
KILL ^TMP("LRC",$JOB)
DO EN1^LR7OSBR(+ORVP)
if '$DATA(^TMP("LRC",$JOB))
QUIT
Begin DoDot:3
+21 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
+22 KILL ^TMP("LRC",$JOB)
End DoDot:3
QUIT
End DoDot:2
+23 IF SS="MI"
KILL ^TMP("LRC",$JOB)
DO EN^LR7OSMZ0(+ORVP)
if '$DATA(^TMP("LRC",$JOB))
QUIT
Begin DoDot:2
+24 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
+25 KILL ^TMP("LRC",$JOB)
End DoDot:2
QUIT
+26 IF SS="CH"
Begin DoDot:2
+27 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
+28 IF TCNT=1
Begin DoDot:4
+29 SET LINE="Collection time: "_$$FMTE^XLFDT(9999999-IVDT,"M")
+30 DO SETLINE(LINE,.LCNT)
+31 DO BLANK^ORCXPND
+32 SET LINE=$$S(1,CCNT," ")_$$S(2,CCNT,"Test Name")_$$S(38,CCNT,"Result")_$$S(48,CCNT,"Units")_$$S(64,CCNT,"Range")
+33 DO SETLINE(LINE,.LCNT)
+34 SET CCNT=0
SET LINE=$$S(1,CCNT," ")_$$S(2,CCNT,"---------")_$$S(38,CCNT,"------")_$$S(48,CCNT,"-----")_$$S(64,CCNT,"-----")
+35 DO SETLINE(LINE,.LCNT)
+36 if $DATA(IOUON)
DO SETVIDEO^ORCXPND(LCNT,1,70,IOUON,IOUOFF)
End DoDot:4
+37 IF TST
SET XT=TEST(SS,IVDT,TST)
SET CCNT=0
IF +XT
Begin DoDot:4
+38 SET NAME=$SELECT($LENGTH($PIECE(^LAB(60,+XT,0),U))>25:$SELECT($LENGTH($PIECE($GET(^(.1)),U)):$PIECE(^(.1),U),1:$EXTRACT($PIECE(^(0),U),1,25)),1:$EXTRACT($PIECE(^(0),U),1,25))
+39 ;OR*3.0*585: Adjusted spacing in line below - $$S(24... instead of $$S(25...
+40 ; and add " " before $$S(31
+41 SET LINE=$$S(1,CCNT,NAME)_$$S(24,CCNT,$JUSTIFY($PIECE(XT,U,2),20))_" "_$$S(31,CCNT,$SELECT($LENGTH($PIECE(XT,U,3)):$PIECE(XT,U,3),1:""))_$$S(48,CCNT,$PIECE(XT,U,4))_$$S(58,CCNT,$JUSTIFY($PIECE(XT,U,5),15)
)
+42 DO SETLINE(LINE,.LCNT)
+43 IF $PIECE(XT,U,20)
SET ^TMP("ORPLS",$JOB,$PIECE(XT,U,20))=""
+44 IF $LENGTH($PIECE(XT,U,3))
IF $DATA(IOINHI)
DO SETVIDEO^ORCXPND(LCNT,26,8,IOINHI,IOINORM)
+45 IF $PIECE(XT,U,3)["*"
IF $DATA(IOBON)
IF $DATA(IOINHI)
DO SETVIDEO^ORCXPND(LCNT,26,8,IOBON_IOINHI,IOBOFF_IOINORM)
End DoDot:4
+46 IF TST="N"
SET LINE=" Comments: "
Begin DoDot:4
+47 DO SETLINE(LINE,.LCNT)
+48 NEW CMT
SET CMT=0
FOR
SET CMT=$ORDER(TEST(SS,IVDT,"N",CMT))
if 'CMT
QUIT
SET LINE=" "_TEST(SS,IVDT,"N",CMT)
DO SETLINE(LINE,.LCNT)
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+49 IF $LENGTH($ORDER(^TMP("ORPLS",$JOB,"")))
DO SETLINE(" ",.LCNT)
DO SETLINE(" ",.LCNT)
DO SETLINE("===============================================================================",.LCNT)
DO PLS
+50 DO SETLINE(" ",.LCNT)
+51 KILL ^TMP("LRRR",$JOB)
+52 QUIT
+53 ;
PLS ; List performing laboratories
+1 NEW LINE,ORPLS,X
+2 DO SETLINE("Performing Lab Sites",.LCNT)
+3 SET ORPLS=0
+4 FOR
SET ORPLS=$ORDER(^TMP("ORPLS",$JOB,ORPLS))
if ORPLS<1
QUIT
Begin DoDot:1
+5 SET LINE=$$LJ^XLFSTR("["_ORPLS_"] ",8)_$$NAME^XUAF4(ORPLS)
+6 DO SETLINE(LINE,.LCNT)
+7 SET X=$$PADD^XUAF4(ORPLS)
+8 SET LINE=$$REPEAT^XLFSTR(" ",8)_$PIECE(X,U)_" "_$PIECE(X,U,2)_", "_$PIECE(X,U,3)_" "_$PIECE(X,U,4)
+9 DO SETLINE(LINE,.LCNT)
End DoDot:1
+10 DO SETLINE("===============================================================================",.LCNT)
+11 KILL ^TMP("ORPLS",$JOB)
+12 QUIT
+13 ;
SETLINE(LINE,CNT) ;
+1 SET CNT=CNT+1
SET ^TMP("ORXPND",$JOB,CNT,0)=LINE
+2 QUIT
+3 ;
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,ORMHP,ORVP,XQORNOD,ORSSTRT,ORSSTOPT,VAOA,CPRSGUI,ORINP,ORATP,ORASS,ORENRI,ORENRD,ORENC,ORESG,A
+2 SET ORVP=DFN_";DPT("
SET XQORNOD=1
SET CPRSGUI=1
+3 ; MAS Patient Inquiry
DO EN^DGRPD
+4 IF $$GET^XPAR("ALL","ORWPT SHOW CAREGIVER")
Begin DoDot:1
+5 WRITE !!,"Caregiver Information:"
+6 NEW ORRET,ORRETS,ORPRIM,ORSEC,ORGEN,ORA,ORD
+7 WRITE !
DO GET^VAFCREL(.ORRET,DFN)
+8 IF $PIECE(ORRET(0),"^")=-1
WRITE "Caregiver information not currently available: ",$PIECE(ORRET(0),"^",2),!
QUIT
+9 IF $PIECE(ORRET(0),"^")=0
WRITE "No Caregiver information returned."
QUIT
+10 SET ORRETS=0
SET ORPRIM=""
SET ORSEC=""
SET ORGEN=""
+11 FOR
SET ORRETS=$ORDER(ORRET(ORRETS))
if 'ORRETS
QUIT
Begin DoDot:2
+12 SET ORA=$GET(ORRET(ORRETS))
IF ORA=""
QUIT
+13 IF $PIECE(ORA,"^",2)="CGP"
IF $PIECE(ORA,"^",5)="ACTIVE"
SET ORD("PRIM",ORRETS)=$PIECE(ORA,"^",8)
QUIT
+14 IF $PIECE(ORA,"^",2)="CGS"
IF $PIECE(ORA,"^",5)="ACTIVE"
SET ORD("SEC",ORRETS)=$PIECE(ORA,"^",8)
QUIT
+15 IF $PIECE(ORA,"^",2)="CGG"
IF $PIECE(ORA,"^",5)="ACTIVE"
SET ORD("GEN",ORRETS)=$PIECE(ORA,"^",8)
+16 QUIT
End DoDot:2
+17 IF $DATA(ORD("PRIM"))
Begin DoDot:2
+18 WRITE ?5,"Primary Caregiver: "
+19 SET ORRETS=0
+20 FOR
SET ORRETS=$ORDER(ORD("PRIM",ORRETS))
if 'ORRETS
QUIT
WRITE ?24,ORD("PRIM",ORRETS),!
+21 WRITE !
End DoDot:2
+22 IF $DATA(ORD("SEC"))
Begin DoDot:2
+23 WRITE ?3,"Secondary Caregiver: "
+24 SET ORRETS=0
+25 FOR
SET ORRETS=$ORDER(ORD("SEC",ORRETS))
if 'ORRETS
QUIT
WRITE ?24,ORD("SEC",ORRETS),!
+26 WRITE !
End DoDot:2
+27 IF $DATA(ORD("GEN"))
Begin DoDot:2
+28 WRITE ?5,"General Caregiver: "
+29 SET ORRETS=0
+30 FOR
SET ORRETS=$ORDER(ORD("GEN",ORRETS))
if 'ORRETS
QUIT
WRITE ?24,ORD("GEN",ORRETS),!
End DoDot:2
End DoDot:1
+31 SET ORENRI=$$FINDCUR^DGENA(DFN)
SET A=$$GET^DGENA(ORENRI,.ORENRD)
SET ORENC=$$CATEGORY^DGENA4(DFN)
SET ORESG=$SELECT($GET(ORENRD("SUBGRP"))]"":$$EXT^DGENU("SUBGRP",ORENRD("SUBGRP")),1:"")
+32 WRITE !!!,"Enrollment Priority: ",$SELECT($GET(ORENRD("PRIORITY"))]"":"GROUP "_$GET(ORENRD("PRIORITY")),1:"")_ORESG,?40,"Category: ",$$EXTCAT^DGENA4(ORENC),!!
+33 KILL CPRSGUI
+34 ;
+35 SET ORDOC=$$OUTPTPR^SDUTL3(DFN)
+36 SET ORTEAM=$$OUTPTTM^SDUTL3(DFN)
+37 ;Retrieve Mental Health Provider
SET ORMHP=$$START^SCMCMHTC(DFN)
+38 SET ORINP=$GET(^DPT(DFN,.104))
+39 SET ORATP=$GET(^DPT(DFN,.1041))
+40 SET ORASS=$PIECE($$OUTPTAP^SDUTL3(DFN,DT),U,2)
+41 IF ORDOC!ORTEAM!ORMHP!ORINP!ORATP
Begin DoDot:1
+42 WRITE !!,"Primary Care Information:"
+43 IF ORDOC
WRITE !,"Primary Practitioner: ",$PIECE(ORDOC,"^",2)
+44 IF ORTEAM
WRITE !,"Primary Care Team: ",$PIECE(ORTEAM,"^",2)
+45 IF $$INPT^ORWPT1(DFN)
Begin DoDot:2
+46 IF ORATP
WRITE !,"Attending Physician: ",$PIECE($GET(^VA(200,+ORATP,0)),U)
+47 IF ORINP
WRITE !,"Inpatient Provider: ",$PIECE($GET(^VA(200,+ORINP,0)),U)
End DoDot:2
+48 IF $LENGTH(ORASS)
WRITE !,"Associate Provider: ",ORASS
+49 IF ORMHP
Begin DoDot:2
+50 WRITE !!,"MH Treatment Information:"
+51 WRITE !,"MH Treatment Coord: ",$EXTRACT($PIECE(ORMHP,"^",2),1,28)
Begin DoDot:3
+52 WRITE ?52,"Position: ",$EXTRACT($PIECE(ORMHP,"^",3),1,18)
End DoDot:3
+53 WRITE !,"MH Treatment Team: ",$EXTRACT($PIECE(ORMHP,"^",5),1,56)
End DoDot:2
End DoDot:1
+54 WRITE !!,"Health Insurance Information:"
+55 ;DBIA #4408
DO DISP^DGIBDSP
+56 WRITE !!,"Service Connection/Rated Disabilities:"
+57 DO DIS^DGRPDB
+58 FOR CONTACT="N","S"
Begin DoDot:1
+59 SET VAOA("A")=$SELECT(CONTACT="N":"",1:3)
+60 ; Get NOK Information
DO OAD^VADPT
+61 IF VAOA(9)]""
Begin DoDot:2
+62 WRITE !!,$SELECT(CONTACT="N":"Next of Kin Information:",1:"Secondary Next of Kin Information:")
+63 ; NOK Name
WRITE !,"Name: ",VAOA(9)
+64 ; Relationship
IF VAOA(10)]""
WRITE " (",VAOA(10),")"
+65 ; Address Line 1
IF VAOA(1)]""
WRITE !?7,VAOA(1)
+66 ; Line 2
IF VAOA(2)]""
WRITE !?7,VAOA(2)
+67 ; Line 3
IF VAOA(3)]""
WRITE !?7,VAOA(3)
+68 IF VAOA(4)]""
Begin DoDot:3
+69 ; City
WRITE !?7,VAOA(4)
+70 ; State
IF VAOA(5)]""
WRITE ", "_$PIECE(VAOA(5),"^",2)
+71 ; Zip+4
WRITE " ",$PIECE(VAOA(11),"^",2)
End DoDot:3
+72 ; Phone
IF VAOA(8)]""
WRITE !!?7,"Phone number: ",VAOA(8)
+73 IF CONTACT="N"
IF $PIECE($GET(^DPT(DFN,.21)),U,11)]""
WRITE !?7,"Work phone number: ",$PIECE(^DPT(DFN,.21),U,11)
+74 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
+75 DO KVAR^VADPT
+76 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
