source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPO5.m@ 1141

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

initial load of WorldVistAEHR

File size: 4.9 KB
Line 
1SCRPO5 ;BP-CIOFO/KEITH - Historical Patient Assignment Detail ; 01 Jul 99 9:30 PM
2 ;;5.3;Scheduling;**177**;AUG 13, 1993
3 ;
4PTDET N DIC,SC,DFN,SCPT0,X,Y,SCDT,DTOUT,DUOUT
5 D TITL^SCRPW50("Historical Patient Assignment Detail")
6 S DIC="^DPT(",DIC(0)="AEMQZ" D ^DIC I $D(DTOUT)!$D(DUOUT) G EXIT
7 G:Y<1 EXIT S DFN=+Y,SCPT0=Y(0),SC="SC",SCDT("B")="TODAY"
8 G:'$$DTR^SCRPO(.SC,.SCDT,.SCDT) EXIT
9 N ZTSAVE F X="DFN","SCPT0","SC(" S ZTSAVE(X)=""
10 W ! D EN^XUTMDEVQ("RUN^SCRPO5","Historical Patient Assignment Detail",.ZTSAVE)
11EXIT D DISP0^SCRPW23,END^SCRPW50 Q
12 ;
13RUN ;Print report
14 N SCI,SCPNOW,SCLINE,SCPAGE,SCSUB,SCFF,SCFOUND,SCLN,SCAGE,SCDATA
15 N SCDOB,SCGEND,SCIFN,SCOUT,SCPNAME,SCREC,SCSH,SCSSN,SCTITL,SCDT
16 K ^TMP("SCRPT",$J) M SCDT=SC("DTR") S SCDT="SCDT"
17 S SCI=$$GETALL^SCAPMCA(DFN,.SCDT),SCSUB="",(SCFF,SCLN,SCFOUND,SCOUT)=0
18 F S SCSUB=$O(^TMP("SC",$J,DFN,SCSUB)) Q:SCSUB=""!(SCSUB]"PCTM") D
19 .S SCX=$P($T(@SCSUB),";;",2) F SCI=1:1:9 S SCX(SCI)=$P(SCX,U,SCI)
20 .S ^TMP("SCRPT",$J,SCX(1))=SCX(2),SCX(3)=U_SCX(3)
21 .S SCI=0 F S SCI=$O(^TMP("SC",$J,DFN,SCSUB,SCI)) Q:'SCI D
22 ..S SCDATA=^TMP("SC",$J,DFN,SCSUB,SCI)
23 ..S SCNAME=$P(SCDATA,U,SCX(8)) ;provider/position/team name
24 ..S SCIFN=$P(SCDATA,U,SCX(4)) ;history record ifn
25 ..S SCACT=$P(SCDATA,U,SCX(5)) ;active date
26 ..Q:'SCACT
27 ..S SCINAC=$P(SCDATA,U,SCX(6)) ;inactive date
28 ..S SCREC=$G(@SCX(3)@(SCIFN,0)) ;history record
29 ..Q:'$L(SCREC)
30 ..S SCUSER=$P(SCREC,U,SCX(7)) ;user duz
31 ..S SCDENT=$P(SCREC,U,SCX(9)) ;date entered
32 ..D SLINE(SCX(1),SCNAME,SCACT,SCINAC,SCUSER,SCDENT,.SCLN)
33 ..Q
34 .Q
35 S SCTITL(1)="<*> HISTORICAL PATIENT ASSIGNMENT DETAIL <*>"
36 S SCTITL(2)="For assignments effective "_SC("DTR","PBDT")_" to "_SC("DTR","PEDT")
37 S SCLINE="",$P(SCLINE,"-",81)="",SCPAGE=1
38 S Y=$$NOW^XLFDT() X ^DD("DD") S SCPNOW=$P(Y,":",1,2)
39 S SCPNAME=$P(SCPT0,U),SCSSN=$P(SCPT0,U,9)
40 S SCGEND=$S($P(SCPT0,U,2)="M":"MALE",1:"FEMALE")
41 S (Y,SCAGE)=$P(SCPT0,U,3) X ^DD("DD") S SCDOB=Y
42 S SCAGE=$E(DT,1,3)-$E(SCAGE,1,3)-($E(DT,4,7)<$E(SCAGE,4,7))
43 D:$E(IOST)="C" DISP0^SCRPW23 D HDR^SCRPO(.SCTITL,80),SHDR
44 W:'SCFOUND !!?21,"No assignments found for this patient."
45 I SCFOUND S SCSUB=0 F S SCSUB=$O(^TMP("SCRPT",$J,SCSUB)) Q:'SCSUB!SCOUT D
46 .D:$Y>(IOSL-5) HDR^SCRPO(.SCTITL,80),SHDR Q:SCOUT
47 .S SCSH=^TMP("SCRPT",$J,SCSUB)
48 .W:SCSUB>1 ! D SSHDR(SCSH) S SCACT=""
49 .I '$O(^TMP("SCRPT",$J,SCSUB,"")) W " (none found)" Q
50 .F S SCACT=$O(^TMP("SCRPT",$J,SCSUB,SCACT)) Q:SCACT=""!SCOUT D
51 ..S SCI=0 F S SCI=$O(^TMP("SCRPT",$J,SCSUB,SCACT,SCI)) Q:'SCI!SCOUT D
52 ...D:$Y>(IOSL-3) HDR^SCRPO(.SCTITL,80),SHDR,SSHDR(SCSH,1) Q:SCOUT
53 ...S SCX=^TMP("SCRPT",$J,SCSUB,SCACT,SCI)
54 ...W !,$P(SCX,U),?28,$P(SCX,U,2),?40,$P(SCX,U,3),?52,$P(SCX,U,4)
55 ...Q
56 ..Q
57 .Q
58 I 'SCOUT,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
59 K ^TMP("SCRPT",$J) Q
60 ;
61SHDR ;Subheader
62 Q:SCOUT
63 W !,"Patient: ",$E(SCPNAME,1,18),?29,"SSN: ",SCSSN,?46,"DOB: ",SCDOB
64 W ?64,"AGE: ",SCAGE,?74,$J(SCGEND,6),!,SCLINE
65 Q:'SCFOUND
66 W !,"Assignment",?28,"Active",?40,"Inactive",?52,"Assigned by/date"
67 W !,"-------------------------- ---------- ---------- ----------------------------"
68 Q
69 ;
70SSHDR(X,CONT) ;Subheader
71 ;Input: X=category
72 ;Input: CONT='1' for continuation (optional)
73 W !,X,$S($G(CONT):" (cont.)",1:""),":"
74 Q
75 ;
76SLINE(SCORD,SCNAME,SCACT,SCINAC,SCUSER,SCDENT,SCLN) ;Set report global
77 ;Input: SCORD=output order
78 ;Input: SCNAME=provider/position/team name
79 ;Input: SCACT=active date
80 ;Input: SCINAC=inactive date
81 ;Input: SCUSER=user duz
82 ;Input: SCDENT=date entered
83 ;
84 N SCX,SCY
85 S SCFOUND=1,SCLN=SCLN+1
86 S SCX=$E(SCNAME,1,25)_U_$$SDT(SCACT)_U_$$SDT(SCINAC),SCY=$$SDT(SCDENT)
87 S:$L(SCY) SCY=" ("_SCY_")"
88 S SCX=SCX_U_$E($P($G(^VA(200,+SCUSER,0)),U),1,(28-$L(SCY)))_SCY
89 S ^TMP("SCRPT",$J,SCORD,-SCACT,SCLN)=SCX
90 Q
91 ;
92CODE ;Data handling instructions
93 ; The following $TEXT lines contain data handling instructions
94 ; in the format: $PIECE 1 = output order
95 ; 2 = subtitle
96 ; 3 = global reference of history record
97 ; 4 = $piece of history record ifn
98 ; 5 = $piece of active date
99 ; 6 = $piece of inactive date
100 ; 7 = $piece of user (in history record)
101 ; 8 = $piece of provider/position/team name
102 ; 9 = $piece of date entered
103 ;
104NPCPOS ;;7^Non-PC Position^SCPT(404.43)^4^5^6^6^2^7
105NPCPPOS ;;9^Non-PC Preceptor Position^SCTM(404.53)^16^14^15^7^2^8
106NPCPPR ;;8^Non-PC Preceptor Provider^SCTM(404.52)^11^9^10^7^2^8
107NPCPR ;;6^Non-PC Provider^SCTM(404.52)^11^9^10^7^2^8
108NPCTM ;;10^Non-PC Team^SCPT(404.42)^3^4^5^11^2^12
109PCAP ;;2^PC Associate Provider^SCTM(404.52)^11^9^10^7^2^8
110PCPOS ;;3^PC Position^SCPT(404.43)^4^5^6^6^2^7
111PCPPOS ;;4^PC Preceptor Position^SCTM(404.53)^16^14^15^7^2^8
112PCPR ;;1^PC Provider^SCTM(404.52)^11^9^10^7^2^8
113PCTM ;;5^PC Team^SCPT(404.42)^3^4^5^11^2^12
114 ;
115SDT(X) ;Slashed date
116 S X=$E(X,1,7) Q:X'?7N ""
117 Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_(17+$E(X))_$E(X,2,3)
Note: See TracBrowser for help on using the repository browser.