source: WorldVistAEHR/trunk/r/SURGERY-SR/SROATCM.m@ 1800

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

initial load of WorldVistAEHR
File size: 4.7 KB
Line 
1SROATCM ;BIR/MAM - TRANSMIT CARDIAC ASSESSMENTS ;03/02/06
2 ;;3.0; Surgery ;**38,55,68,90,93,95,99,125,153**;24 Jun 93;Build 11
3 ;
4 ; Reference to ^DGPM("APTT1" supported by DBIA #565
5 ; Reference to File #405 supported by DBIA #3029
6 ; Reference to Field #27.02 in File #2 supported by DBIA #1850
7 ;
8 K ^TMP("SRA",$J) S SRATOT=0,SRASITE=+$P($$SITE^SROVAR,"^",3),(SRAMNUM,SRACNT)=1
9 S SRADFN=0 F S SRADFN=$O(^SRF("ARS","C","C",SRADFN)) Q:'SRADFN S SRTN=0 F S SRTN=$O(^SRF("ARS","C","C",SRADFN,SRTN)) Q:'SRTN D STUFF
10 S SRATOTM=SRAMNUM D ^SROATCM2
11 Q
12STUFF ; stuff entries into ^TMP("SRA",$J
13 ; check for fouled up ARS x ref
14 I $P(^SRF(SRTN,"RA"),"^",2)="N" K ^SRF("ARS","C","C",SRADFN,SRTN) K DR S DIE=130,DR="235///C",DA=SRTN D ^DIE K DR Q
15 ; the next line is commented out to allow re-transmissions
16 ;S SRART=$P(^SRF(SRTN,"RA"),"^",3) I SRART S DIE=130,DR="235///T",DA=SRTN D ^DIE K DR,DA,DIE Q
17 I $P(^SRF(SRTN,"RA"),"^",2)'="C" Q
18 I SRACNT>100 S SRACNT=1,SRAMNUM=SRAMNUM+1
19 S SRATOT=SRATOT+1 K SRA,VADM
20 F I=0,200,205:1:208 S SRA(I)=$G(SRF(SRTN,I))
21 D ^SROATCM1,P93
22 K SHEMP,SRA,VADM,VAPA
23 S X=$E($P(^SRF(SRTN,0),"^",9),1,5)_"00",^TMP("SRWL",$J,X)=""
24 Q
25P93 ; referring & follow-up sites, patient address & phone number
26 N SRPREF,SRREF,SRREFP,SRFOL,SRFOLP,SRSOUT,SRY S (SRPREF,SRREF,SRREFP,SRFOL,SRFOLP)="",SRSOUT=0,(VAIP("D"),SRSDATE)=$P(SRA(0),"^",9) D IN5^VADPT
27 ; if not admitted before surgery, look for admission within 24 hours of leaving OR
28 I 'VAIP(13) S X1=$P($G(^SRF(SRTN,.2)),"^",12),X2=1 D C^%DTC S SR24=X,SRDT=$O(^DGPM("APTT1",DFN,SRSDATE)) G:'SRDT!(SRDT>SR24) TS S VAIP("D")=SRDT D IN5^VADPT
29TS I VAIP(13) K DA,DIC,DIQ,DR S DIC=405,DR=.05,DA=VAIP(13),DIQ="SRY",DIQ(0)="IE" D EN^DIQ1 S SRREF=SRY(405,VAIP(13),.05,"E"),SRREFP=SRY(405,VAIP(13),.05,"I") I SRREFP S SRREFP=$$GET1^DIQ(4,SRREFP,99)
30 I VAIP(17) K DA,DIC,DIQ,DR,SRY S DIC=405,DR=.05,DA=VAIP(17),DIQ="SRY",DIQ(0)="IE" D EN^DIQ1 S SRFOL=SRY(405,VAIP(17),.05,"E"),SRFOLP=SRY(405,VAIP(17),.05,"I") I SRFOLP S SRFOLP=$$GET1^DIQ(4,SRFOLP,99)
31 S SHEMP=$E(SHEMP,1,11)_" 18"_$J(VAPA(1),35)_$J(VAPA(2),30),^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
32 S SHEMP=$E(SHEMP,1,11)_" 19"_$J(VAPA(3),30)_$J(VAPA(4),15)
33 K DA,DIC,DIQ,DR,SRY S X=$P(VAPA(5),"^") I X S DIC=5,DA=X,DR=1,DIQ="SRY",DIQ(0)="E" D EN^DIQ1 S X=SRY(5,$P(VAPA(5),"^"),1,"E")
34 S SHEMP=SHEMP_$J(X,5),^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1,SHEMP=$E(SHEMP,1,11)_" 20"_$J(VAPA(8),20)_$J($TR(SRREF,","," "),30)_$J(SRREFP,6)
35 K DA,DIC,DIQ,DR,SRY S DIC="^DPT(",DIQ="SRY",DIQ(0)="I",DA=DFN,DR=27.02 D EN^DIQ1 S X=$G(SRY(2,DFN,27.02,"I")) I X S SRPREF=$$GET1^DIQ(4,X,99)
36 S SHEMP=SHEMP_$J(SRPREF,6)
37 S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1,SHEMP=$E(SHEMP,1,11)_" 21"_$J($TR(SRFOL,","," "),30)_$J(SRFOLP,6)
38 S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
39 S SHEMP=$E(SHEMP,1,11)_" 22"_$J($P(SRA(201),"^",21),6)_$J($P(SRA(202),"^",21),7)_$J($P(SRA(201),"^",22),6)_$J($P(SRA(202),"^",22),7)
40 S SHEMP=SHEMP_$J($P(SRA(201),"^",23),6)_$J($P(SRA(202),"^",23),7)_$J($P(SRA(201),"^",24),6)_$J($P(SRA(202),"^",24),7)
41 S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
42 ;
43 S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SHEMP=$E(SHEMP,1,11)_" 23"_$J($P(SRA(201),"^",25),6)_$J($P(SRA(202),"^",25),7)_$J($P(SRA(201),"^",26),6)_$J($P(SRA(202),"^",26),7)_$J($P(VADM(3),"^"),7) K VADM
44 S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
45 S SHEMP=$E(SHEMP,1,11)_" 24"_$J($P(SRA(208),"^",10),2)_$J($P(SRA(206),"^",38),2)_$J($P(SRA(207),"^",24),2)_$J($P(SRA(207),"^",25),2)_$J($P(SRA(206),"^",39),2)
46 N SR22,SR23 S SR22=$P(SRA(208),"^",22),SR23=$P(SRA(208),"^",23)
47 D NMCS S SHEMP=SHEMP_$J(SRIP,2)_$J(" ",2)_$S(SR22:$J(SR22,12,4),1:$J(SR22,12))_$S(SR23:$J(SR23,12,4),1:$J(SR23,12))_$J($P(SRA(206),"^",41),2)
48 S SHEMP=SHEMP_$J($P(SRA(207),"^",26),3)
49 ;
50 N VAINDT,SRPTF,SRRES,SRDISTYP
51 S VAINDT=$P(SRA(208),"^",15)-.0001 D INP^VADPT S SRPTF=VAIN(10)
52 S SRRES="" D RPC^DGPTFAPI(.SRRES,SRPTF)
53 S SRRES(0)=$G(SRRES(0)),SRRES(1)=$G(SRRES(1)),SRRES(2)=$G(SRRES(2))
54 S SRDISTYP=$P(SRRES(1),U)
55 I SRDISTYP]"" S SRDISTYP=$S(SRDISTYP="REGULAR":1,SRDISTYP="NBC OR WHILE ASIH":2,SRDISTYP="EXPIRATION 6 MONTH LIMIT":3,SRDISTYP="IRREGULAR":4,SRDISTYP="TRANSFER":5,SRDISTYP="DEATH WITH AUTOPSY":6,SRDISTYP="DEATH WITHOUT AUTOPSY":7,1:"")
56 S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP_$J($P(SRRES(1),U,3),7),SRACNT=SRACNT+1
57 S SHEMP=$E(SHEMP,1,11)_" 25"_$J(SRDISTYP,2) I $D(SRRES(2)) F I=1:1:9 S SHEMP=SHEMP_$J($P(SRRES(2),"^",I),7)
58 S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
59 D ^SROATCM3
60 Q
61NMCS S SRIP=$P(SRA(206),"^",40) I SRIP'="Y" Q
62 N SROCC S SROCC=0 F S SROCC=$O(^SRF(SRTN,10,SROCC)) Q:'SROCC I $P(^SRF(SRTN,10,SROCC,0),"^",2)=34 S SRIP="I" Q
63 I SRIP="Y" S SROCC=0 F S SROCC=$O(^SRF(SRTN,16,SROCC)) Q:'SROCC I $P(^SRF(SRTN,16,SROCC,0),"^",2)=34 S SRIP="P" Q
64 Q
Note: See TracBrowser for help on using the repository browser.