- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQPTQ1.m
r613 r623 1 ORQPTQ1 ; SLC/CLA - Functs which return OR patient lists and sources pt 1 ; 8/20/07 5:43am2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,74,63,91,85,139,243**;Dec 17, 1997;Build 242 3 VAMCPTS(Y) 4 5 6 7 8 VAMCLONG(Y,DIR,FROM) 9 10 11 12 13 14 15 16 17 18 DEFTM(ORY) 19 20 21 22 23 TEAMS(ORY) 24 25 26 27 28 29 .I $P($G(^OR(100.21,ORTM,11)),U)'=0!($D(^OR(100.21,ORTM,1,$G(DUZ,0))))S ORY(I)=ORTM_U_ORTMN,I=I+130 31 32 TEAMPTS(ORY,TEAM,TMPFLAG) 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 TEAMPR(ORY,PROV) 56 57 58 59 60 61 62 63 64 TEAMPR2(ORY,PROV) 65 66 67 68 69 70 71 72 73 74 75 76 TEAMPROV(ORY,TEAM) 77 78 79 80 81 82 83 84 85 TPROVPT(PROV) 86 87 88 89 90 91 92 93 94 95 96 97 98 99 TMSPT(ORY,PT) 100 101 102 103 104 105 106 107 108 109 110 TPTPR(ORY,PT) 111 112 113 114 115 116 117 118 119 120 PERSPR(ORY) 121 122 123 124 125 126 127 128 129 PRIMPT(ORY,ORPT) 130 131 132 133 134 135 136 137 138 139 140 141 142 PROVPT(ORY,ORPT) 143 144 145 146 PPLINK(ORPROV,ORPT) 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 PDLINK(ORDEV,ORPT) 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 PCMMLINK(ORPROV,ORPT) 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 PUNSIGN(ORY,ORBDFN) 197 198 199 200 201 202 203 204 205 206 207 208 209 1 ORQPTQ1 ; SLC/CLA - Functs which return OR patient lists and sources pt 1 ;12/15/97 [ 04/02/97 3:32 PM ] [6/6/01 11:34am] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,74,63,91,85,139**;Dec 17, 1997 3 VAMCPTS(Y) ; RETURN LIST OF PATIENTS IN VAMC: DFN^NAME 4 N I,J,V 5 S I=1 6 S J=0 F S J=$O(^DPT("B",J)) Q:J="" S V=0,V=$O(^DPT("B",J,V)) S Y(I)=V_"^"_J,I=I+1 7 Q 8 VAMCLONG(Y,DIR,FROM) ; return a bolus of patients in VAMC: DFN^NAME 9 N I,IEN,CNT S CNT=44 10 I DIR=0 D ; Forward direction 11 . F I=1:1:CNT S FROM=$O(^DPT("B",FROM)) Q:FROM="" D 12 . . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM 13 . I +$G(Y(CNT))="" S Y(I)="" 14 I DIR=1 D ; Reverse direction 15 . F I=1:1:CNT S FROM=$O(^DPT("B",FROM),-1) Q:FROM="" D 16 . . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM 17 Q 18 DEFTM(ORY) ; return current user's default team list 19 Q:'$D(DUZ) 20 N ORSRV S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) 21 S ORY=$$GET^XPAR("USR^SRV.`"_+$G(ORSRV),"ORLP DEFAULT TEAM",1,"B") 22 Q 23 TEAMS(ORY) ; return list of teams for a system 24 ; Also called under DBIA # 2692. 25 N ORTM,I,ORTMN 26 S ORTMN="",I=1 27 F S ORTMN=$O(^OR(100.21,"B",ORTMN)) Q:ORTMN="" D 28 .S ORTM="",ORTM=$O(^OR(100.21,"B",ORTMN,ORTM)) Q:ORTM="" 29 .S ORY(I)=ORTM_U_ORTMN,I=I+1 30 S:+$G(ORY(1))<1 ORY(1)="^No teams found." 31 Q 32 TEAMPTS(ORY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS IN A TEAM 33 ; Also called under DBIA # 2692. 34 ; If TMPFLAG passed and = TRUE, code expects a "^TMP(xxx" 35 ; global root string passed in ORY, and builds the returned 36 ; list in that global instead of to a memory array. 37 N DOTMP,NEWTMP 38 S DOTMP=0 39 I $G(TMPFLAG) D ; Was value passed? 40 .I TMPFLAG S DOTMP=1 ; Is value TRUE? 41 I +$G(TEAM)<1 D 42 .I DOTMP S NEWTMP=ORY_1_")",@NEWTMP="^No team identified" Q 43 .I 'DOTMP S ORY(1)="^No team identified" Q 44 N ORI,ORPT,I 45 S I=0 46 S ORI=0 F S ORI=$O(^OR(100.21,+TEAM,10,ORI)) Q:ORI<1 D 47 .S ORPT=^OR(100.21,+TEAM,10,ORI,0) 48 .I DOTMP D 49 ..S I=I+1,NEWTMP=ORY_+I_")" 50 ..S @NEWTMP=+ORPT_U_$P(^DPT(+ORPT,0),U) 51 .I 'DOTMP S I=I+1,ORY(I)=+ORPT_U_$P(^DPT(+ORPT,0),U) 52 I DOTMP S:I<1 NEWTMP=ORY_1_")",@NEWTMP="^No patients found." 53 I 'DOTMP S:I<1 ORY(1)="^No patients found." 54 Q 55 TEAMPR(ORY,PROV) ; return list of teams linked to a provider 56 I +$G(PROV)<1 S ORY(1)="^No provider identified" Q 57 N ORTM,I,ORTMN 58 S ORTM="",I=1 59 F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D 60 .S ORTMN=$P(^OR(100.21,ORTM,0),U) 61 .S ORY(I)=ORTM_U_ORTMN,I=I+1 62 S:+$G(ORY(1))<1 ORY(1)="^No teams found." 63 Q 64 TEAMPR2(ORY,PROV) ; return list of teams linked to a provider 65 ; This tag added by PKS/slc - 8/1999. 66 I +$G(PROV)<1 S ORY(1)="^No provider identified" Q 67 N ORTM,ORDATA,ORTMN,ORTYPE,I 68 S ORTM="",I=1 69 F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D 70 .S ORDATA=^OR(100.21,ORTM,0) ; Get value. 71 .S ORTMN=$P(ORDATA,U) ; Team List name. 72 .S ORTYPE=$P(ORDATA,U,2) ; Team List type. 73 .S ORY(I)=ORTM_U_ORTMN_U_ORTYPE,I=I+1 74 S:+$G(ORY(1))<1 ORY(1)="^No teams found." 75 Q 76 TEAMPROV(ORY,TEAM) ; return list of providers linked to a team 77 I +$G(TEAM)<1 S ORY(1)="^No team identified" 78 N PROV,I,SEQ 79 S I=1 80 S SEQ=0 F S SEQ=$O(^OR(100.21,+TEAM,1,SEQ)) Q:SEQ<1 D 81 .S PROV=^OR(100.21,+TEAM,1,SEQ,0) I $L(PROV) D 82 ..S ORY(I)=+PROV_U_$P(^VA(200,+PROV,0),U),I=I+1 83 S:+$G(ORY(1))<1 ORY(1)="^No providers found." 84 Q 85 TPROVPT(PROV) ;return list of patients linked to a provider via teams 86 ; Modified by PKS: 8/1999. 87 I +$G(PROV)<1 S ^TMP("ORLPUPT",$J,"^No provider identified")="" 88 N ORTM,ORTMN,ORI,ORPT 89 S ORTM="" 90 F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D ; Teams. 91 .S ORTMN=$P(^OR(100.21,+ORTM,0),U,1) ; Get name of Team List. 92 .S ORI=0 F S ORI=$O(^OR(100.21,+ORTM,10,ORI)) Q:ORI<1 D 93 ..S ORPT=^OR(100.21,+ORTM,10,ORI,0) 94 ..S ^TMP("ORLPUPT",$J,+ORPT_U_$P(^DPT(+ORPT,0),U))="" 95 ..; Next line added by PKS: 96 ..S ^TMP("ORLPUPT",$J,"B",ORTMN,$P(^DPT(+ORPT,0),U)_U_+ORPT)="" 97 I '$D(^TMP("ORLPUPT",$J)) S ^TMP("ORLPUPT",$J,"^No patients found.")="" 98 Q 99 TMSPT(ORY,PT) ;return list of teams linked to a patient (patient is active) 100 I +$G(PT)<1 S ORY(1)="^No patient identified" Q 101 N ORTM,I,ORTMN,ORTMTYP 102 S ORTM="",I=1 103 F S ORTM=$O(^OR(100.21,"AB",+PT_";DPT(",ORTM)) Q:+$G(ORTM)<1 D 104 .S ORTMN=$P(^OR(100.21,ORTM,0),U) 105 .S ORTMTYP=$P(^OR(100.21,ORTM,0),U,2) I $L(ORTMTYP) D 106 ..S ORTMTYP=$$EXTERNAL^DILFD(100.21,1,"",ORTMTYP,"") 107 .S ORY(I)=ORTM_U_ORTMN_U_$S($L(ORTMTYP):ORTMTYP,1:"no type"),I=I+1 108 S:+$G(ORY(1))<1 ORY(1)="^No teams found." 109 Q 110 TPTPR(ORY,PT) ;return list of providers linked to a patient via teams 111 I +$G(PT)<1 S ORY(1)="^No patient identified" Q 112 N ORTM,PROV,SEQ 113 S ORTM="" 114 F S ORTM=$O(^OR(100.21,"AB",+PT_";DPT(",ORTM)) Q:+$G(ORTM)<1 D 115 .S SEQ=0 F S SEQ=$O(^OR(100.21,+ORTM,1,SEQ)) Q:SEQ<1 D 116 ..S PROV=^OR(100.21,+ORTM,1,SEQ,0) I $L(PROV) D 117 ...S ORY(+PROV)=+PROV_U_$P(^VA(200,+PROV,0),U) 118 S:'$D(ORY) ORY(1)="^No providers found." 119 Q 120 PERSPR(ORY) ; return list of personal lists linked to current user 121 N ORTM,I,ORTMN 122 S ORTM="",I=1 123 F S ORTM=$O(^OR(100.21,"C",DUZ,ORTM)) Q:+$G(ORTM)<1 D 124 .Q:$P(^OR(100.21,ORTM,0),U,2)'="P" ;quit if not a personal list 125 .S ORTMN=$P(^OR(100.21,ORTM,0),U) 126 .S ORY(I)=ORTM_U_ORTMN,I=I+1 127 S:+$G(ORY(1))<1 ORY(1)="^No personal lists found." 128 Q 129 PRIMPT(ORY,ORPT) ; return patient's PCMM primary care team 130 I +$G(ORPT)<1 S ORY(1)="^No patient identified" 131 N ORQPUR,ORQERROR,ORQLST,ORQERR,ORQDT,ORIDT,ORADT,ORX 132 S ORQPUR(2)="" ;"2" is the ien for purpose "primary care" [^SD(403.47] 133 D NOW^%DTC S ORQDT("BEGIN")=%-.0001,ORQDT("END")=%+.0001,ORQDT("INCL")=0 134 S ORQERROR=$$TMPT^SCAPMC(.ORPT,"ORQDT","ORQPUR","ORQLST","ORQERR") 135 I ORQERROR=0 S ORY="^Error in search for primary care team." 136 I +$G(ORQLST(1))>0 D 137 .S ORX=ORQLST(1),ORADT=$P(ORX,U,4),ORIDT=$P(ORX,U,5) 138 .I ($G(ORADT)>$G(ORIDT)) S ORY=$P(ORX,U)_U_$P(ORX,U,2) 139 S:+$G(ORY)<1 ORY="^No primary care team found." 140 K % 141 Q 142 PROVPT(ORY,ORPT) ; return PCMM primary provider for a patient 143 I +$G(ORPT)<1 S ORY(1)="^No patient identified" 144 S ORY(1)=$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1) 145 Q 146 PPLINK(ORPROV,ORPT) ; returns '1' if patient is linked to provider 147 N ORX,ORPP 148 S ORX="",ORPP=0 149 I (+$G(ORPT)<1)!(+$G(ORPROV)<1) Q 0 150 I $D(^DPT("APR",ORPROV,ORPT)) Q "1^PRIM" ;provider is patient's primary 151 I $D(^DPT("AAP",ORPROV,ORPT)) Q "1^ATTD" ;provider is patient's attending 152 ;is provider and patient on the same team: 153 D TPROVPT(ORPROV) 154 F S ORX=$O(^TMP("ORLPUPT",$J,ORX)) Q:ORX="" D 155 .I +ORX=ORPT S ORPP="1^OERRTM" Q 156 K ^TMP("ORLPUPT",$J) 157 ; 158 ;If not linked already, see if linked via PCMM: 159 I ORPP=0 S ORPP=$$PCMMLINK(ORPROV,ORPT) 160 ; 161 Q ORPP 162 PDLINK(ORDEV,ORPT) ; returns '1' if patient is linked to device via team 163 ;ORDEV can be either ien or device name 164 N ORY,ORX,ORTM,ORDP,ORTMDEV,ORDEVIEN 165 S ORDP=0 166 I (+$G(ORPT)<1)!($L($G(ORDEV))<1) Q 0 167 ; Are device and patient on the same team?: 168 I '$D(^%ZIS(1,ORDEV,0)) D ;ORDEV is not an ien 169 .S ORDEVIEN=0,ORDEVIEN=$O(^%ZIS(1,"B",$P(ORDEV,U),ORDEVIEN)) 170 .S ORDEV=ORDEVIEN 171 Q:+$G(ORDEV)<1 0 172 D TMSPT(.ORY,ORPT) 173 S ORX="" F S ORX=$O(ORY(ORX)) Q:ORX="" D 174 .S ORTM=ORY(ORX) 175 .I $D(^OR(100.21,+ORTM,0)),$P(^(0),U,4)=ORDEV S ORDP=1 Q 176 Q ORDP 177 PCMMLINK(ORPROV,ORPT) ;returns '1' if patient is linked to provider via PCMM 178 N ORPP,ORPCMM,ORPCP 179 S ORPP=0 180 I (+$G(ORPT)<1)!(+$G(ORPROV)<1) Q 0 181 ; 182 ;provider is patient's PCMM primary care practitioner: 183 I ORPROV=+$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1) Q "1^PCP" ;DBIA #1252 184 ; 185 ;provider is patient's PCMM associate provider: 186 I ORPROV=+$$OUTPTAP^SDUTL3(ORPT,$$NOW^XLFDT) Q "1^AP" ;DBIA #1252 187 ; 188 ;provider is linked to patient via PCMM team position assignment: 189 S ORPCMM=$$PRPT^SCAPMC(ORPT,,,,,,"^TMP(""ORPCMMLK"",$J)",) ;DBIA #1916 190 S ORPCP=0 191 F S ORPCP=$O(^TMP("ORPCMMLK",$J,"SCPR",ORPCP)) Q:'ORPCP!ORPP=1 D 192 .I ORPROV=ORPCP S ORPP="1^PCMMTM" 193 K ^TMP("ORPCMMLK",$J) 194 ; 195 Q ORPP 196 PUNSIGN(ORY,ORBDFN) ;rtns array of providers with unsigned orders for pt 197 N ORDG,ORX,ORZ,ORDNUM 198 S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 199 K ^TMP("ORR",$J) 200 ;get unsigned orders: 201 D EN^ORQ1(ORBDFN_";DPT(",ORDG,11,"","","",0,0) 202 S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" 203 I +$G(^TMP("ORR",$J,ORX,"TOT"))>0 D 204 .S ORX="" F S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" D 205 ..S ORZ="" F S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:+$G(ORZ)<1 D 206 ...S ORDNUM=^TMP("ORR",$J,ORX,ORZ) 207 ...S ORY(+$$UNSIGNOR^ORQOR2(+ORDNUM))="" 208 K ^TMP("ORR",$J) 209 Q
Note:
See TracChangeset
for help on using the changeset viewer.
