- 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 Jan 18, 2025@03:30:18 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