source: FOIAVistA/trunk/r/SURGERY-SR/SROPCE0B.m@ 1166

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

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1SROPCE0B ;BIR/ADM - PCE FILING STATUS REPORT, SHORT FORM ;12/16/98 2:10 PM
2 ;;3.0; Surgery ;**58,62,69,77,50,86,118,142**;24 Jun 93
3 ;
4 ; Reference to ^ECC(723 supported by DBIA #205
5 ; Reference to ^SCE("AVSIT" supported by DBIA #2045
6 ; Reference to File #409.68 supported by DBIA #2045
7 ;
8 D HDR F S SRSDT=$O(^SRF("AC",SRSDT)) Q:'SRSDT!(SRSDT>SRSEDT)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSDT,SRTN)) Q:'SRTN I $D(^SRF(SRTN,0)),$$DIV^SROUTL0(SRTN),$P($G(^SRF(SRTN,30)),"^")="" D UTIL Q:SRSOUT
9 D:'SRSOUT TOTAL
10 Q
11TOTAL D:$Y+9>IOSL PAGE Q:SRSOUT W !!,?13,"FILED: ",$J(CNT(1),5),!,?9,"NOT FILED: "_$J(CNT(4),5)
12 F I=1:1:5 S CNT(6)=CNT(6)+CNT(I)
13 W:CNT(5) !,?9,"UNCERTAIN: "_$J(CNT(5),5) W !,?20,"-----",!,?7,"TOTAL CASES: ",$J(CNT(6),5)
14 Q
15UTIL ; process case
16 S SRDIV=$P($G(^SRF(SRTN,8)),"^") I SRDIV S SRSPS=$O(^SRO(133,"B",SRDIV,0))
17 I 'SRDIV S SRSPS=SRSITE
18 S X=^SRO(133,SRSPS,0),SRPARAM=$P(X,"^",15),SRSR=$P(X,"^",19) I SRPARAM=""!(SRPARAM="N") Q
19 S SRINOUT=$P(^SRF(SRTN,0),"^",12) I SRPARAM="O",SRINOUT'="",SRINOUT'="O" Q
20 S SRNON=0 I $P($G(^SRF(SRTN,"NON")),"^")="Y" S SRNON=1
21 I SRFLG=1!(SRFLG=3&('SRNON)),'$P($G(^SRF(SRTN,.2)),"^",12) Q
22 I SRFLG=2!(SRFLG=3&SRNON),'$P($G(^SRF(SRTN,"NON")),"^",5) Q
23 I (SRFLG=2&('SRNON))!(SRFLG=1&(SRNON)) Q
24 S SRSS=$S('SRNON:$P(^SRF(SRTN,0),"^",4),1:$P(^SRF(SRTN,"NON"),"^",8)) I SRSPEC,SRSPEC'=SRSS Q
25 S SRSSNM=$S('SRNON:$P(^SRO(137.45,SRSS,0),"^"),1:$P(^ECC(723,SRSS,0),"^"))
26 I SRPARAM="O",SRINOUT="" S SRSTATUS=5,CNT(5)=CNT(5)+1 D CASE,CHK^SROPCE0,MISS Q
27 I $P(^SRF(SRTN,0),"^",15) S SRSTATUS=1,CNT(1)=CNT(1)+1 D CASE,LINE Q
28 S SRSTATUS=4,CNT(4)=CNT(4)+1 D CASE,CHK^SROPCE0,MISS
29 Q
30MISS ; list fields missing data
31 Q:SRSOUT S SRFLD="" S SRFLD=$O(SRX(SRFLD)) I SRFLD="" W !,?15,"No Missing Information" D LINE Q
32 S SRCT=1,SRFLD="" W !!,?15,"Missing Information:" F S SRFLD=$O(SRX(SRFLD)) Q:SRFLD="" D:$Y+5>IOSL PAGE Q:SRSOUT W !,$J(SRCT_". ",20),SRX(SRFLD) S SRCT=SRCT+1
33LINE I 'SRSOUT W ! F I=1:1:80 W "-"
34 Q
35SCHED ; get appointment status from Scheduling
36 N SRENC,SRVSIT,SRX S SRSCHED="<NONE>",SRVSIT=$P(SR(0),"^",15) Q:'SRVSIT
37 S SRENC=$O(^SCE("AVSIT",SRVSIT,0)) Q:'SRENC
38 S DA=SRENC,DIC=409.68,DR=".12",DIQ="SRX",DIQ(0)="E" D EN^DIQ1 K DA,DIC,DIQ,DR
39 I SRX(409.68,SRENC,.12,"E")="INPATIENT APPOINTMENT" S SRX(409.68,SRENC,.12,"E")="INPATIENT APPT"
40 S X=SRX(409.68,SRENC,.12,"E") I X'="" S SRSCHED=X
41 Q
42CASE ; print case info
43 D:$Y+9>IOSL PAGE Q:SRSOUT D DEM,PROC,SCHED
44 W !,SRSDATE,?22,SRSNM,?44,SRSSN_" ("_SRAGE_")",?66,$S(SRSTATUS=1:"FILED",SRSTATUS=4:"NOT FILED",1:"UNCERTAIN")
45 W !,SRTN,?22,$E(SRSSNM,1,20),?66,$E(SRSCHED,1,14),! W:(SRFLG=3)&SRNON "NON-O.R." W ?22,SRPROC(1) W:$D(SRPROC(2)) !,?22,SRPROC(2) W:$D(SRPROC(3)) !,?22,SRPROC(3)
46 Q
47DEM ; get patient demographic information
48 S SR(0)=^SRF(SRTN,0),DFN=$P(SR(0),"^") D DEM^VADPT S SRSNM=VADM(1),SRSSN=VA("PID"),Y=SRSDT X ^DD("DD") S SRSDATE=Y,X1=$E(SRSDT,1,7),X2=$P(VADM(3),"^"),SRAGE=$E(X1,1,3)-$E(X2,1,3)-($E(X1,4,7)<$E(X2,4,7))
49 I $L(SRSNM)>20 S SRSNM=$P(VADM(1),",")_","_$E($P(VADM(1),",",2))_"."
50 Q
51PROC ; get principal procedure
52 K SRPROC S X=$P(^SRF(SRTN,"OP"),"^") I $L(X)<56 S SRPROC(1)=X
53 I $L(X)>55 S K=1 F D I $L(X)<56 S SRPROC(K)=X Q
54 .F I=0:1:54 S J=55-I,Y=$E(X,J) I Y=" " S SRPROC(K)=$E(X,1,J-1),X=$E(X,J+1,$L(X)) S K=K+1 Q
55 Q
56PAGE I $E(IOST)="P"!SRHDR G HDR
57 W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
58HDR ; print heading
59 I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
60 W:$Y @IOF W:$E(IOST)="P" !,?(80-$L(SRINST)\2),SRINST W !,?(80-$L(SRRPT)\2),SRRPT,?70,$J("PAGE "_SRPAGE,9),!,?(80-$L(SRTITLE)\2),SRTITLE,!,?(80-$L(SRFRTO)\2),SRFRTO W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT
61 W !!,"DATE OF "_$S(SRFLG=1:"OPERATION",SRFLG=2:"PROCEDURE",1:"OP/PROCEDURE"),?22,"PATIENT NAME",?44,"PATIENT ID (AGE)",?66,"FILING STATUS",!,"CASE #",?22,"SPECIALTY",?66,"SCHED STATUS",!,?22,"PRINCIPAL PROCEDURE"
62 S SRHDR=0,SRPAGE=SRPAGE+1 W ! F I=1:1:80 W "="
63 Q
Note: See TracBrowser for help on using the repository browser.