source: FOIAVistA/trunk/r/SPINAL_CORD_DYSFUNCTION-SPN/SPNLS.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 4.6 KB
Line 
1SPNLS ;ISC-SF/RAH - EXTRACT CONTROL FOR LOCAL TO NATIONAL ;8/31/95 14:13
2V ;;2.0;Spinal Cord Dysfunction;**2**;01/02/1997
3EN ;
4 K ^TMP("SPNX",$J),^TMP("SPNLS",$J),^TMP("SPNXMRK",$J)
5 S (SPNLERR,SPNLLOC,SPNLFULL,SPNLHDR,SPNLPTS)=""
6 S (SPNLH,SPNLPCNT,SPNLTMP)=0,SPNLCTXT=1
7CKR ;
8 ;I '$D(ZTQUEUED) D SETVARS,EN1^SPNLSCH Q
9MAINLIN ;
10 D INIT^SPNLGE(.SPNLERR)
11 D SETVARS
12 I SPNLERR D ERRMSG Q
13 D CALCSTOP
14 D LOOP ; Loop thru Registry
15 D SNDMAIL
16 D ^SPNLS1 ; Update control files and re-schedule
17 D END
18 Q
19LOOP ;
20 S SPNLPID=SPNSTRID
21 F S SPNLPID=$O(^SPNL(154,SPNLPID)) Q:SPNLPID'>0 D Q:SPNLH>SPNLSTP
22 .S SPNLLID=SPNLPID,SPNLH1=$P($H,",",1),SPNLH2=$P($H,",",2),SPNLH=SPNLH1_"."_SPNLH2
23 .I $P($G(^SPNL(154,SPNLPID,0)),U,3,4)'="1^T" Q ; Active & Transmit
24 .I '$P($G(^SPNL(154,SPNLPID,"XMT")),U),'$$CK1541(SPNLPID) Q ; Any Changes to Record
25 .S SPNLPTS="",SPNLERR=""
26 .S:$D(^SPNL(154.9,SPNLPID,0)) SPNLPTS=^SPNL(154.9,SPNLPID,0)
27 .I SPNLPTS="" S SPNLPTS=SPNLPID_U_U D CRATEREC Q:SPNLERR
28 .I $P(SPNLPTS,U,2)="" S $P(SPNLPTS,U,2)="1000100"
29 .I $P(SPNLPTS,U,3)="" S $P(SPNLPTS,U,3)="1000100"
30 .S SPNLFDT=$E($P(SPNLPTS,U,3),1,5)_"01",SPNLTDT=SPNLSDT
31 .S SPNLERR="" D EXTRACT^SPNLGE(SPNLPID,SPNLFDT,SPNLTDT,SPNLCTXT,.SPNLERR)
32 .I SPNLERR D ERRMSG Q
33 .S SPNLPCNT=SPNLPCNT+1
34 .S ^TMP("SPNLS",$J,SPNLPID)=SPNLPID_U_SPNLFDT_U_SPNLTDT
35 .Q
36 I SPNLPID'>0 S SPNLFULL=1,SPNLPID=1
37 I 'SPNLFULL S SPNLTYPE="PARTIAL"
38 Q
39CK1541(DFN) ; Check the 154.1 globle for a entry CAN be sent.
40 N SPNLFLG,SPNLIEN
41 S (SPNLFLG,SPNLIEN)=0
42 F S SPNLIEN=$O(^SPNL(154.1,"B",DFN,SPNLIEN)) Q:SPNLIEN<1 D Q:SPNLFLG
43 . Q:$G(^SPNL(154.1,SPNLIEN,0))="" ; Bad zero node
44 . S SPNLFLG=+$P($G(^SPNL(154.1,SPNLIEN,"XMT")),U) ; send OR not to send.
45 . Q
46 Q SPNLFLG
47CRATEREC ;
48 K DD,DIC,DINUM,DO
49 S DIC(0)="LMN",DIC="^SPNL(154.9,",X=SPNLPID,DINUM=SPNLPID,DLAYGO=154.9
50 D FILE^DICN K DIC,DINUM
51 I Y=-1 S SPNLERR="1 COULD NOT MAKE ENTRY "_SPNLPID_" IN PTN TX FILE" D ERRMSG Q
52 S SPNLPIEN=$P(Y,U,1)
53 Q
54PTXIEN ;
55 S DIC(0)="MNO",DIC="^SPNL(154.9,",X=SPNLPID D ^DIC K DIC
56 I Y=-1 S SPNLERR="3 COULD NOT FIND ENTRY "_SPNLPID_" IN PTN TX FILE" D ERRMSG Q
57 S SPNLPIEN=$P(Y,U,1)
58 Q
59SETVARS ;
60 S SPNLTMP=.9
61 S SPNLTMP=$O(^SPNL(154.93,SPNLTMP))
62 I SPNLTMP="" D
63 .S SPNLTMP=1 K DD,DIC,DINUM,DO
64 .S DIC(0)="LMN",DIC="^SPNL(154.93,",X=1,DINUM=1,DLAYGO=154.93
65 .D FILE^DICN K DIC
66 .S ^SPNL(154.93,1,0)="1^^^^^FULL^0^0^1"
67 S SPNLTXCY=^SPNL(154.93,SPNLTMP,0)
68 I $P(SPNLTXCY,U,10)="" S $P(SPNLTXCY,U,10)=0
69 I $P(SPNLTXCY,U,6)="" S $P(SPNLTXCY,U,7)="FULL"
70 S SPNLCYNO=$P(SPNLTXCY,U,1),SPNLTIME=$P(SPNLTXCY,U,10),SPNLCYST=$P(SPNLTXCY,U,2)
71 I $D(^SPNL(154.91,1,0)) S SPNPARMS=^SPNL(154.91,1,0)
72 E S SPNPARMS="^1000^240^1W"
73 I $P(SPNPARMS,U,2)="" S $P(SPNPARMS,U,2)=1000
74 I $P(SPNPARMS,U,3)="" S $P(SPNPARMS,U,3,4)="240^1W"
75 S SPNXRECS=$P(SPNPARMS,U,2),SPNXRUN=$P(SPNPARMS,U,3)
76 S SPNSTRID=$P(SPNLTXCY,U,10),SPNLTYPE=$P(SPNLTXCY,U,6)
77 S SPNLFREQ=$P(SPNPARMS,U,4)
78 S SPNLLOC="^TMP(""SPNX"",$J,"
79 K X,% D NOW^%DTC S SPNLSDT=X,SPNLSDAT=%,SPNLSTRT=%
80 S SPNLFAC=$P(^SPNL(154.91,1,0),U,1)
81 S SPNLXMY=$P(^SPNL(154.91,1,0),U,7)
82 S SPNLFNAM=$P(^DIC(4,$P(^XMB(1,1,"XUS"),U,17),0),U,1)
83 S SPNLNODE=SPNLFNAM_U_SPNXRUN_U_SPNLFREQ_U_SPNLCYST_U_U_SPNLTYPE_U_SPNLSDAT_U_U
84 S ^TMP("SPNX",$J,SPNLSDT,SPNLFAC)=SPNLNODE
85SETHDR ;
86 S SPNLHDR="SCD"_U_SPNLFAC_U_SPNLSDT_U_SPNLTYPE_U_SPNLCYNO_U_SPNXRECS_U_SPNXRUN_U_SPNLTIME_U_"1.5"
87 S SPNLSUB="SCD"_"$"_SPNLFAC_"$"_"SPINAL CORD"_"$"_SPNLSDT
88 Q
89CALCSTOP ;
90 S SPNLDAYS=$P($H,",",1),SPNLSEC=$P($H,",",2),SPNLSEC=SPNLSEC+(SPNXRUN*60)
91 I SPNLSEC>86399 D
92 .F S SPNLDAYS=SPNLDAYS+1,SPNLSEC=SPNLSEC-86400 Q:SPNLSEC<86400
93 S SPNLSTP=SPNLDAYS_"."_SPNLSEC
94 Q
95SNDMAIL ;
96 D EN1^SPNLXMD(SPNLLOC,SPNLSUB,SPNLXMY,.SPNLERR)
97 I SPNLERR D ERRMSG
98 Q
99ERRMSG ;
100 K X,% D NOW^%DTC S SPNLDT=%
101 S XMSUB=$S(+SPNLERR=4:"SCD REGISTRY EXTRACT MESSAGE",1:"SCD REGISTRY EXTRACT ERROR")
102 S XMY("G.SPNL SCD COORDINATOR")=""
103 S SPNLFAC=$P(^DIC(4,$P(^XMB(1,1,"XUS"),U,17),99),U,1),SPNLFAC=+$E(SPNLFAC,1,3)
104 S SPNLFNAM=$P(^DIC(4,$P(^XMB(1,1,"XUS"),U,17),0),U,1)
105 S SPNLTEXT(1)="H$ "_SPNLDT_"^"_SPNLFAC_"^"_SPNLFNAM
106 S SPNLTEXT(2)="I$ "_SPNLPID_"^"_SPNLHDR
107 S SPNLTEXT(3)="P$ "_SPNPARMS
108 S SPNLTEXT(4)="C$ "_SPNLTXCY
109 S SPNLTEXT(5)="E$ "_SPNLERR
110 S XMDUZ=.5,XMTEXT="SPNLTEXT("
111 S:'$D(DTIME) DTIME=300 D ^XMD
112 Q
113END ;
114 D DIE^SPNLRU1
115 K SPNLCT,SPNLCTXT,SPNLCYNO,SPNLCYST,SPNLDAYS,SPNLERR,SPNLFAC,SPNLFNAM
116 K SPNLFREQ,SPNLFULL,SPNLHDR,SPNLLID,SPNLLOC,SPNLMOS,SPNLNODE,SPNLPCNT
117 K SPNLPID,SPNLPTS,SPNLSDAT,SPNLSDT,SPNLSEC,SPNLSSN,SPNLSTP,SPNLSUB
118 K SPNLT,SPNLTIME,SPNLTXCY,SPNLTYPE,SPNLXMY,SPNLYRS,SPNPARMS,SPNSTRID
119 K SPNXRECS,SPNXRUN,ZTRTN,ZTDTH,ZTIO,ZTSK,ZTDESC
120 K SPNLDT,SPNLFDT,SPNLTDT,SPNLH,SPNLH1,SPNLH2,SPNLPIEN,SPNLSTRT,SPNLTEXT
121 K ^TMP("SPNX",$J),^TMP("SPNLS",$J),^TMP("SPNXMRK",$J)
122 Q
Note: See TracBrowser for help on using the repository browser.