source: FOIAVistA/tag/r/SURGERY-SR/SROPCE1.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1SROPCE1 ;BIR/ADM - ASK SC/EI QUESTIONS FOR PCE AND CROSS REFERENCE LOGIC ;07/24/07
2 ;;3.0; Surgery ;**58,105,119,150,152,159**;24 Jun 93;Build 4
3 ;
4 ; Reference to CL^SDCO21 supported by DBIA #406
5 ; Reference to DIS^DGRPDB supported by DBIA #700
6 ; Reference to Field #.322013 in File #2 supported by DBIA #3475
7 ;
8EN1 I '$P(^SRO(133,SRSITE,0),"^",16) Q
9 N SRPDATE,SRSDATE S SRPDATE=$P(^SRO(133,SRSITE,0),"^",17),SRSDATE=$S($D(SRTN):$P(^SRF(SRTN,0),"^",9),$D(SRWLST):$P(^SRO(133.8,SRSS,1,SROFN,0),"^",5),1:DT) I SRPDATE,SRSDATE<SRPDATE Q
10 N SRAO,SRDR,SREC,SRELIG,SRIR,SRPERC,SRQ,SRSC,SRCL,SRX,VAEL,VASV,SRCV,SRMST,SRHNC,SRPRJ S SRQ=0
11CLASS ; build classification array
12 S:$D(SRTN) DFN=$P(^SRF(SRTN,0),"^") D CL^SDCO21(DFN,SRSDATE,,.SRCL)
13 I '$D(SRCL) W !!,"No classification information is required for this patient.",! K DA,DIE,DR S:$D(SRTN) DA=SRTN,DIE=130,DR=".0155////1" S:$D(SRWLST) DA(1)=SRSS,DA=SROFN,DIE="^SRO(133.8,"_DA(1)_",1,",DR="20////1" D ^DIE G END
14 I $D(SRTN),'$P(^SRF(SRTN,0),"^",20) G ELIG
15 I $D(SRWLST),'$P(^SRO(133.8,SRSS,1,SROFN,0),"^",20) G ELIG
16ASK W ! K DIR S DIR("A")="Do you want to update classification information (Y/N)? ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR I 'Y!$D(DTOUT)!$D(DUOUT) W:'$D(SRWLST) @IOF Q
17ELIG ; output of eligibility and service connected conditions
18 N SRY D DEM^VADPT,ELIG^VADPT,SVC^VADPT
19 S SRELIG=$P(VAEL(1),"^",2),SRSC=$P(VAEL(3),"^"),SRSC=$S(SRSC:"YES",SRSC=0:"NO",1:""),SRPERC=$P(VAEL(3),"^",2)
20 S SRAO=$S(VASV(2):"YES",1:"NO"),SRIR=$S(VASV(3):"YES",1:"NO"),SRCV=$S(VASV(10):"YES",1:"NO"),SRPRJ=$S($G(VASV(11)):"YES",1:"NO")
21 S SRMST=$S($D(SRCL(5)):"YES",1:"NO"),SRHNC=$S($D(SRCL(6)):"YES",1:"NO")
22 S DIC=2,DA=DFN,DR=".322013",DIQ="SRY",DIQ(0)="I" D EN^DIQ1 K DA,DIC,DIQ,DR
23 S SREC=SRY(2,DFN,.322013,"I"),SREC=$S(SREC="Y":"YES",1:"NO")
24 W @IOF,!,VADM(1)_" ("_VA("PID")_") ",$P(VAEL(6),"^",2),!!," * * * Eligibility Information and Service Connected Conditions * * *"
25 W !!,?5,"Primary Eligibility: "_SRELIG,!,?5,"Combat Vet: "_SRCV,?22,"A/O Exp.: "_SRAO,?39,"M/S Trauma: "_SRMST
26 W !,?5,"ION Rad.: "_SRIR,?22,"SWAC: "_SREC,?39,"H/N Cancer: "_SRHNC
27 W !,?5,"PROJ 112/SHAD: "_SRPRJ
28 D DIS^DGRPDB
29 W ! F I=1:1:79 W "-"
30SUP S SRY="operation" I $D(SRTN),$P($G(^SRF(SRTN,"NON")),"^")="Y" S SRY="procedure"
31 K DIR W !!,"Please supply the following required information about this "_SRY_":",! S:$D(SRWLST) DA(1)=SRSS,DA=SROFN S:$D(SRTN) DA=SRTN S SRDR="" S:'$D(SRQ) SRQ=0 D I SRQ S:$D(SRWLST) SRSOUT=1 G END
32 .I $D(SRCL(3)) D SC I SRQ Q
33 .I $D(SRCL(7)) D CV I SRQ Q
34 .I $D(SRCL(1)) D AO I SRQ Q
35 .I $D(SRCL(2)) D IR I SRQ Q
36 .I $D(SRCL(4)) D EC I SRQ Q
37 .I $D(SRCL(8)) D PRJ I SRQ Q
38 .I $D(SRCL(5)) D MST I SRQ Q
39 .I $D(SRCL(6)) D HNC
40 K DA,DIE,DR S:$D(SRTN) DA=SRTN,DIE=130,DR=SRDR_".0155////1" S:$D(SRWLST) DA(1)=SRSS,DA=SROFN,DIE="^SRO(133.8,"_DA(1)_",1,",DR=SRDR_"20////1"
41 D ^DIE
42UPDX I $D(SRTN),X,$D(^SRF(SRTN,15)) D
43 .R !!,"Update all 'OTHER POSTOP DIAGNOSIS' Eligibility and",!,"Service Connected Conditions with these values? Enter YES or NO. <NO>",Z:DTIME S:'$T Z=""
44 .D:(Z["Y")!(Z["y") UPDSC
45 .I Z["?" D G UPDX
46 ..W !!,"Associate all of the existing OTHER POSTOP DIAGNOSIS for this surgical case with the new Eligibility and Service Connected Conditions?"
47 ..W !,"To edit diagnoses classification status individually, please use the Physician's Verification or the CPT/ICD9 Coding screens"
48END K DA,DIE,DR,SRZ,X,Y I 'SRQ,'$D(SRREQ),'$D(SRWLST) D PRESS
49 Q
50SC S DIR("A")="Treatment related to Service Connected condition (Y/N)",DIR(0)=$S($D(SRWLST):"133.801,16",1:"130,.016") D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q
51 I X=""!(X="@") W !,$C(7),?15,"Enter YES or NO." G SC
52 S SRCL(3)=Y,SRDR=$G(SRDR)_$S($D(SRWLST):"16",1:".016")_"////"_SRCL(3)_";"
53 S SRCL(3,"UPDATE")=1
54 Q
55CV N SRCVD S SRCVD=$S($D(SRWLST):$P(^SRO(133.8,SRSS,1,SROFN,0),"^",23),1:$P(^SRF(SRTN,0),"^",24)),DIR("B")=$S(SRCVD=0:"NO",1:"YES")
56 S DIR("A")="Treatment related to Combat (Y/N)",DIR(0)=$S($D(SRWLST):"133.801,23",1:"130,.024") D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q
57 I X=""!(X="@") W !,$C(7),?15,"Enter YES or NO." G CV
58 S SRCL(7)=Y,SRDR=SRDR_$S($D(SRWLST):"23",1:".024")_"////"_SRCL(7)_";"
59 S SRCL(7,"UPDATE")=1
60 Q
61AO S DIR("A")="Treatment related to Agent Orange Exposure (Y/N)",DIR(0)=$S($D(SRWLST):"133.801,17",1:"130,.017") D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q
62 I X=""!(X="@") W !,$C(7),?15,"Enter YES or NO." G AO
63 S SRCL(1)=Y,SRDR=SRDR_$S($D(SRWLST):"17",1:".017")_"////"_SRCL(1)_";"
64 S SRCL(1,"UPDATE")=1
65 Q
66IR S DIR("A")="Treatment related to Ionizing Radiation Exposure (Y/N)",DIR(0)=$S($D(SRWLST):"133.801,18",1:"130,.018") D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q
67 I X=""!(X="@") W !,$C(7),?15,"Enter YES or NO." G IR
68 S SRCL(2)=Y,SRDR=SRDR_$S($D(SRWLST):"18",1:".018")_"////"_SRCL(2)_";"
69 S SRCL(2,"UPDATE")=1
70 Q
71EC S DIR("A")="Treatment related to SW Asia (Y/N)",DIR(0)=$S($D(SRWLST):"133.801,19",1:"130,.019") D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q
72 I X=""!(X="@") W !,$C(7),?15,"Enter YES or NO." G EC
73 S SRCL(4)=Y,SRDR=SRDR_$S($D(SRWLST):"19",1:".019")_"////"_SRCL(4)_";"
74 S SRCL(4,"UPDATE")=1
75 Q
76PRJ S DIR("A")="Treatment related to PROJ 112/SHAD (Y/N)",DIR(0)=$S($D(SRWLST):"133.801,24",1:"130,.026") D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q
77 I X=""!(X="@") W !,$C(7),?15,"Enter YES or NO." G PRJ
78 S SRCL(8)=Y,SRDR=SRDR_$S($D(SRWLST):"24",1:".026")_"////"_SRCL(8)_";"
79 S SRCL(8,"UPDATE")=1
80 Q
81MST S DIR("A")="Treatment related to Military Sexual Trauma (Y/N)",DIR(0)=$S($D(SRWLST):"133.801,21",1:"130,.022") D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q
82 I X=""!(X="@") W !,$C(7),?15,"Enter YES or NO." G MST
83 S SRCL(5)=Y,SRDR=SRDR_$S($D(SRWLST):"21",1:".022")_"////"_SRCL(5)_";"
84 S SRCL(5,"UPDATE")=1
85 Q
86HNC S DIR("A")="Treatment related to Head and/or Neck Cancer (Y/N)",DIR(0)=$S($D(SRWLST):"133.801,22",1:"130,.023") D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q
87 I X=""!(X="@") W !,$C(7),?15,"Enter YES or NO." G HNC
88 S SRCL(6)=Y,SRDR=SRDR_$S($D(SRWLST):"22",1:".023")_"////"_SRCL(6)_";"
89 S SRCL(6,"UPDATE")=1
90 Q
91WL ; entry from waiting list
92 N SRWLST S SRWLST=1 G EN1
93 Q
94REQ ; entry from new request entry
95 N SRREQ S SRREQ=1 G EN1
96PRESS W ! K DIR S DIR("A")="Press RETURN to continue ",DIR(0)="FOA" D ^DIR K DIR W @IOF
97 Q
98UPDSC ;Update existing DX to Service Connected/Environmental Indicators associations.
99 K DA,DIE
100 S (DA,I)=0,DA(1)=SRTN,DIE="^SRF("_SRTN_",15,"
101 K DR
102 D:$D(SRCL(1,"UPDATE")) BLDDR(5,SRCL(1))
103 D:$D(SRCL(2,"UPDATE")) BLDDR(6,SRCL(2))
104 D:$D(SRCL(3,"UPDATE")) BLDDR(4,SRCL(3))
105 D:$D(SRCL(4,"UPDATE")) BLDDR(9,SRCL(4))
106 D:$D(SRCL(5,"UPDATE")) BLDDR(7,SRCL(5))
107 D:$D(SRCL(6,"UPDATE")) BLDDR(8,SRCL(6))
108 D:$D(SRCL(7,"UPDATE")) BLDDR(10,SRCL(7))
109 D:$D(SRCL(8,"UPDATE")) BLDDR(11,SRCL(8))
110 F I=1:1 S DA=$O(^SRF(SRTN,15,DA)) Q:DA="" D ^DIE
111 Q
112BLDDR(DXPIECE,NEWSC) ;Build the DR string for updating DX/Service Indicators associations
113 S:$D(DR) DR=DR_";"
114 S:'$D(DR) DR=""
115 S DR=DR_DXPIECE_"///"_NEWSC
116 K DXPIECE,NEWSC
117 Q
Note: See TracBrowser for help on using the repository browser.