source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORLPR0.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.8 KB
Line 
1ORLPR0 ; SLC/CLA - Report formatter for patient lists ;11/27/91 [3/22/00 12:41pm]
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**47**;Dec 17, 1997
3 ;
4OUTPUT ;called by TaskMan via ORUTL1 (ORUTL1 queued output was setup by INQ)
5 ; SLC/PKS - Modified 8/99.
6 U IO
7 N ORTDATA,ORTDEV,ORTCREAT,ORTSUB,ORTTYPE
8 S (PR,PF,PAGE)=1,ORLOUT="",ORTIT=$S(TL="TA":"Team Patient Autolinked List",TL="TM":"Team Patient Manual List",TL="MRAL":"Team Patient Manual Removal/Autolinked List",1:"Personal Patient List"),ORTIT(1)=$P(ORLIST,U,2)
9 S:$E(IOST,1,2)'="C-" ORSNUM=1 D HEADING K ORSNUM
10 S ORTDATA=^OR(100.21,+ORLIST,0) ; Get 0-node data.
11 S ORTDEV=$P(ORTDATA,U,4) ; Assign "device."
12 I ORTDEV'="" D ; "Device" exist?
13 . S ORTDEV=$$GET1^DIQ(3.5,+($G(ORTDEV)),.01) ; Get device name.
14 S ORTCREAT=$P(ORTDATA,U,5) ; Assign "creator."
15 I ORTCREAT'="" D ; "Creator" exist?
16 . S ORTCREAT=$P($G(^VA(200,ORTCREAT,0)),U) ; Get creator's name.
17 S ORTTYPE=$P(ORTDATA,U,2) ; Assign type.
18 I ORTTYPE'="" D TYPESTR ; Full type string.
19 S ORTSUB="" ; Initialize.
20 I TL["A" D ; A/L type?
21 . S ORTSUB=$P(ORTDATA,U,6) ; Assign "subcribe."
22 . I ORTSUB="" S ORTSUB="NO" ; Default for no data.
23 . I ORTSUB="Y" S ORTSUB="YES" ; Full word.
24 ; Put in a blank line if no device, creator, type, or subscribe info:
25 I (ORTDEV'="")!(ORTCREAT'="")!(ORTTYPE'="")!(ORTSUB'="") W !
26 I ORTCREAT'="" W !," Creator: "_ORTCREAT ; Write creator line.
27 I ORTDEV'="" W !," Device: "_ORTDEV ; Write device line.
28 I ORTTYPE'="" W !," Type: "_ORTTYPE ; Write type line.
29 I TL["A" W !," Subscribable: "_ORTSUB ; Subscribe line.
30 S ORI=0 F S ORI=$O(^OR(100.21,+ORLIST,1,ORI)) Q:ORI<1 S USER=^(ORI,0) D
31 . S ^TMP("ORLP",$J,"LIST","B",$P(^VA(200,+USER,0),"^"))=""
32 D USER
33 I TL["A",$O(^OR(100.21,+ORLIST,2,0)) S PR=1 D D ALINK
34 . N VP,OROK
35 . S ORI=0 F S ORI=$O(^OR(100.21,+ORLIST,2,ORI)) Q:'ORI D
36 .. S VP=^(ORI,0),VP(1)="^"_$P($P(VP,";",2),U),VP(2)=+VP I $L(VP,"^")=2 S VP(3)=$S($P(VP,U,2)="A":"Attending",$P(VP,U,2)="P":"Primary",1:"Primary or Attending")
37 .. S OROK=0
38 .. I VP(1)["DIC(42," S OROK=1,VPNM="Ward......."_$P(@(VP(1)_VP(2)_",0)"),U)
39 .. I VP(1)["VA(200," S OROK=1,VPNM="Provider..."_$P(@(VP(1)_VP(2)_",0)"),U)_" - as "_VP(3)
40 .. I VP(1)["DIC(45.7," S OROK=1,VPNM="Specialty.."_$P(@(VP(1)_VP(2)_",0)"),U)
41 .. I VP(1)["DG(405.4," S OROK=1,VPNM="Room/Bed..."_$P(@(VP(1)_VP(2)_",0)"),U)
42 .. I VP(1)["SC" S OROK=1,VPNM="Clinic....."_$P(@(VP(1)_VP(2)_",0)"),U)
43 .. I 'OROK S VPNM="(Undetermined) - "_$P(@(VP(1)_VP(2)_",0)"),U)
44 .. S ^TMP("ORLP",$J,"LIST","AL",VPNM)=""
45 S ORI=0 F S ORI=$O(^OR(100.21,+ORLIST,10,ORI)) Q:ORI<1 D
46 . N VAERR,VAIN,DFN
47 . S PAT=^OR(100.21,+ORLIST,10,ORI,0),DFN=+PAT,PAT=^DPT(DFN,0)
48 . D INP^VADPT Q:VAERR S WRD=$S(VAIN(4):$E($P(VAIN(4),U,2),1,10),1:"WD-none"),RMBED=$S(VAIN(5)]"":VAIN(5),1:"unassigned"),SSN=$E($P(PAT,U,9),6,9)_"0000",PATNM=$P(PAT,U)
49 . I SORT="T" S ^TMP("ORLP",$J,"LIST","C","A"_$E(SSN,1,4),PATNM,WRD_": "_RMBED)="" Q
50 . I SORT="R" S ^TMP("ORLP",$J,"LIST","C",WRD_": "_RMBED,PATNM,$E(SSN,1,4))="" Q
51 . S ^TMP("ORLP",$J,"LIST","C",$P(PAT,"^"),$E(SSN,1,4),WRD_": "_RMBED)=""
52 D PT
53 I ORLOUT'["^" W !!?5,"List completed." D
54 . I $E(IOST)="C" S DIR(0)="E" D ^DIR
55 I $D(ZTQUEUED) S ZTREQ="@"
56END ;called by INQ, flow thru from OUTPUT
57 K ALINK,DIR,L,LINE,ORI,ORLOUT,ORTIT,PAGE,PAT,PATNM,PF,PR,PT,PTRB,PTSSN,RMBED,SSN,USER,VPNM,WRD,X1,X2,X3,Y,%ZIS,ZTDESC,ZTRTN,ZTSAVE
58 K ^TMP("ORLP",$J,"LIST")
59 Q
60 ;
61HEADING ;called by OUTPUT, USER, PT - build list heading & handle paging
62 Q:ORLOUT["^"
63 I $$S^%ZTLOAD S ORLOUT="^",ZTSTOP=1 Q
64 I PAGE>1,($E(IOST)="C") S DIR(0)="E" D ^DIR I Y<1 S ORLOUT="^" Q
65 W:'$D(ORSNUM) @IOF
66 W !,$P($$HTE^XLFDT($H),"@"),?(IOM-$L(ORTIT)/2),ORTIT,?70,"page ",PAGE
67 W !?(IOM-$L(ORTIT(1))/2),ORTIT(1) W !?(IOM-$L(ORTIT(1))/2)-2 F L=0:1 W "=" Q:L=($L(ORTIT(1))+4)
68 S (PR,PF)=1,PAGE=PAGE+1
69 Q
70ALINK ;called by OUTPUT - build entries (autolinks)
71 S ALINK="" F S ALINK=$O(^TMP("ORLP",$J,"LIST","AL",ALINK)) Q:ALINK="" D
72 . I $L(ALINK)'<1,($Y+2>IOSL) D HEADING Q:ORLOUT["^"
73 . I PR=1 W !!," Autolinks: ",ALINK S PR=2
74 . E W !?16,ALINK
75 Q
76USER ;called by OUTPUT - build list entries (users)
77 S USER="" F S USER=$O(^TMP("ORLP",$J,"LIST","B",USER)) Q:USER="" D
78 . I $L(USER)'<1,($Y+2>IOSL) D HEADING Q:ORLOUT["^"
79 . I PR=1 W !!,"Provider/users: ",USER S PR=2
80 . E W !?16,USER
81 Q
82PT ;called by OUTPUT - build list entries (patients)
83 N DOTS,SPACE,WRDL
84 S $P(DOTS,".",34)="",$P(SPACE," ",28)="",WRDL=""
85 S X1="" F S X1=$O(^TMP("ORLP",$J,"LIST","C",X1)) Q:X1="" D
86 . S X2="" F S X2=$O(^TMP("ORLP",$J,"LIST","C",X1,X2)) Q:X2="" D
87 .. S X3="" F S X3=$O(^TMP("ORLP",$J,"LIST","C",X1,X2,X3)) Q:X3="" D
88 ... ; sort="T" Terminal digit sort
89 ... I SORT="T" S LINE="("_$E(X1,2,5)_") "_$E(X2_DOTS,1,33)_" "_$E(X3_SPACE,1,27) D PT1 Q
90 ... ; sort="R" Room/Bed sort
91 ... I SORT="R" D D PT1 Q
92 .... I PF=1 S LINE=$E(X1_SPACE,1,27)_" "_$E(X2_DOTS,1,33)_" ("_X3_")" Q
93 .... I WRDL'=$P(X1,":") S LINE=$E(X1_SPACE,1,27)_" "_$E(X2_DOTS,1,33)_" ("_X3_")" Q
94 .... S LINE=$E($E(SPACE,1,$L(WRDL)+1)_$P(X1,":",2)_SPACE,1,27)_" "_$E(X2_DOTS,1,33)_" ("_X3_")"
95 ... ; else sort alpha by patient name
96 ... S LINE=$E(X1_DOTS,1,33)_"("_X2_") "_X3 D PT1
97 Q
98 ;
99PT1 I $L(X1)'<1,($Y+3>IOSL) D HEADING Q:ORLOUT["^"
100 I SORT="R" S WRDL=$P(X1,":") I PF=1 S LINE=$E(X1_SPACE,1,27)_" "_$E(X2_DOTS,1,33)_" ("_X3_")"
101 I PF=1 W !!,"Patients: " S PF=2
102 W !?3,LINE
103 Q
104TYPESTR ; Assign description strings to ORTTYPE (Team List type) variables.
105 ; Tag by PKS - 8/99.
106 ;
107 I ORTTYPE="P" S ORTTYPE="PERSONAL"
108 I ORTTYPE="TA" S ORTTYPE="AUTOLINK"
109 I ORTTYPE="TM" S ORTTYPE="MANUAL"
110 I ORTTYPE="MRAL" S ORTTYPE="MRAL"
111 Q
Note: See TracBrowser for help on using the repository browser.