source: WorldVistAEHR/trunk/r/ASISTS-OOPS/OOPSDOLX.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.8 KB
Line 
1OOPSDOLX ;WIOFO/CAH-Extract data for DOL XMIT ;3/15/00
2 ;;2.0;ASISTS;**8,11**;Jun 03, 2002
3 ;
4 ; Note: have changed this routine to strip the spaces out of the
5 ; last name. This is for ASISTS GUI but needs to be implemented
6 ; for roll and scroll also.
7 ;
8 ;Retrieves data from ^OOPS(2260, for CA1/CA2
9 ;Variables used
10 ; OOPDA-----IEN of Case
11 ; OOPSAR----Array holding data
12 ; OPL-------Last line number written in message text
13 ; XMZ-------Message Number
14 ; Entry
15 N ARR,KK,FN,FORM,MESS,NAME,OPC,OPSAR,OPT,OPX,SEG,OOPSAR,FYM,MON
16 S RSIZE=0,ARR=0
17 S OOPSAR(0)=$$UP^OOPSUTL4($G(^OOPS(2260,OOPDA,0)))
18 S OOPSAR("2162A")=$$UP^OOPSUTL4($G(^OOPS(2260,OOPDA,"2162A")))
19 S OOPSAR("2162B")=$$UP^OOPSUTL4($G(^OOPS(2260,OOPDA,"2162B")))
20 S OOPSAR("2162D")=$$UP^OOPSUTL4($G(^OOPS(2260,OOPDA,"2162D")))
21 S OOPSAR("2162ES")=$$UP^OOPSUTL4($G(^OOPS(2260,OOPDA,"2162ES")))
22OP02 ; Seg OP01
23 K OPX,DTINJ
24 S OPX="OP01^"_$TR($P(OOPSAR(0),U),"-")_U_$P(OOPSAR(0),U,2)
25 S OPX=OPX_U_$P(OOPSAR(0),U,7)_U_$TR($P(OOPSAR("2162A"),U),"-")
26 ; patch 11 - send field 109 if CA1, field 214 if CA2
27 ; left old code, commented below
28 S FORM=$$GET1^DIQ(2260,OOPDA,52,"I")
29 I FORM=1 D
30 . S DTINJ=$$GET1^DIQ(2260,OOPDA,109,"I")
31 . S OPX=OPX_U_$$DC^OOPSUTL3($P(DTINJ,"."))
32 . S Y=DTINJ D DD^%DT S Y=$P($TR(Y,":",""),"@",2),OPX=OPX_U_Y
33 I FORM=2 D
34 . S DTINJ=$$GET1^DIQ(2260,OOPDA,214,"I")
35 . S OPX=OPX_U_$$DC^OOPSUTL3($P(DTINJ,"."))_U
36 K DTINJ
37 ;
38 ; S OPX=OPX_U_$$DC^OOPSUTL3($P($P(OOPSAR(0),U,5),"."))
39 ; I $$GET1^DIQ(2260,OOPDA,52,"I")=1 D
40 ; .S Y=$P(OOPSAR(0),U,5) D DD^%DT S Y=$P($TR(Y,":",""),"@",2)
41 ; .S OPX=OPX_U_Y
42 ; I $$GET1^DIQ(2260,OOPDA,52,"I")=2 S OPX=OPX_U
43 S MON=$E($P(OOPSAR(0),U,5),4,5)
44 S FYM=$S(MON=10:1,MON=11:2,MON=12:3,MON="01":4,MON="02":5,MON="03":6,MON="04":7,MON="05":8,MON="06":9,MON="07":10,MON="08":11,MON="09":12,1:0)
45 S OPX=OPX_U_$E($P(OOPSAR(0),U),1,4)_U_$E("00",$L(FYM)+1,2)_FYM
46 S NAME=$P(OOPSAR(0),U,2),FN=$P(NAME,",",2)
47 F KK=1:0:1 Q:$E(FN,KK)'=" " S FN=$E(FN,KK+1,$L(FN))
48 ; added $TR below to strip spaces out of name
49 S OPX=OPX_U_$P($TR(NAME," ",""),",")_U_$P(FN," ")_U_$E($P(FN," ",2))
50 S OPX=OPX_"^^"_$P(OOPSAR("2162A"),U,4)_U_$P(OOPSAR("2162A"),U,5)_U_$$GET1^DIQ(2260,OOPDA,"10:1")_U_$E($P(OOPSAR("2162A"),U,7),1,5)
51 S OPX=OPX_U_$TR($P(OOPSAR("2162A"),U,8),"(,)-^*/# ")
52 S OPX=OPX_U_$E($$GET1^DIQ(2260,OOPDA,7,"E"))_U_$$DC^OOPSUTL3($P(OOPSAR("2162A"),U,2))
53 ; Patch 5 llh - changed next line from "70:.01" to 331
54 S OPX=OPX_U_$$GET1^DIQ(2260,OOPDA,331)
55 S OPX=OPX_"^^"_$P(OOPSAR("2162A"),U,10)_"^|"
56 D STORE
57 I $P(OOPSAR(0),U,7)=1 D ^OOPSDOL1
58 I $P(OOPSAR(0),U,7)=2 D ^OOPSDOL2
59EXIT ; Loads the message and Quits the routine
60 I RSIZE+MSIZE>30000 D
61 .S END=$P($P(^OOPS(2260,OPAST,0),U),"-",2)
62 .D SEND^OOPSDOL,CREATE^OOPSDOL
63 .S (START,END)=""
64 F I=1:1:ARR I $G(MESS(I))'="" D
65 .S OPL=OPL+1,^XMB(3.9,XMZ,2,OPL,0)=MESS(I)
66 .I START="" S START=$P($P(OOPSAR(0),U),"-",2)
67 S MSIZE=MSIZE+RSIZE
68 K ARR,MESS,OPDT,RSIZE
69 Q
70STORE ;
71 S ARR=ARR+1,MESS(ARR)=OPX
72 S RSIZE=RSIZE+$L(OPX)+2
73 Q
74WP ; Word Processing Fields
75 K OPX
76 N DIWL,DIWR,DIWF,OPGLB,OPNODE,X,OPI,NUM,WPAR,F332,F347
77 S NUM=0,OPI=0
78 K ^UTILITY($J,"W")
79 S DIWL=1,DIWR="",DIWF="|C132"
80 ; Patch 5 llh - added logic to concatenate field 332 to WP field (165)
81 I OPFLD=165 D
82 .S F332=$$GET1^DIQ(2260,OOPDA,"332:1")
83 .I $G(F332)'="" S X=F332 D ^DIWP
84 .;v2 p11 - concatenate Reason for Dispute to fld 165 in block 36
85 .S F347=$$GET1^DIQ(2260,OOPDA,"347:.01")
86 .I $G(F347)'="" S X=F347 D ^DIWP
87 S OPNODE=$P($$GET1^DID(2260,OPFLD,"","GLOBAL SUBSCRIPT LOCATION"),";")
88 S OPI=0 F S OPI=$O(^OOPS(2260,OOPDA,OPNODE,OPI)) Q:'OPI S X=$G(^OOPS(2260,OOPDA,OPNODE,OPI,0)) D
89 . I $TR(X," ","")="" Q
90 . I X]"" D ^DIWP
91 S OPT=$G(^UTILITY($J,"W",1))+0
92 ; If OPT=0 then no data in ^UTILITY($J,"W") so quit
93 I 'OPT Q
94 ; Need to set up an array to see if max segments exceeded
95 I OPT S OPI=0 F OPC=1:1:OPT S OPI=$O(^UTILITY($J,"W",1,OPI)) Q:'OPI D
96 . S NUM=NUM+1
97 . S WPAR(NUM)=SEG_U_OPC_U_OPT_U_$$UP^OOPSUTL4($E(^UTILITY($J,"W",1,OPI,0),1,132))_"^|"
98 ; Fileman puts spaces at end of last node - need to strip off.
99 S STRP=$P(WPAR(NUM),U,4)
100 F K=$L(STRP):-1:1 Q:$E(STRP,K)'=" " S STRP=$E(STRP,1,(K-1))
101 S $P(WPAR(NUM),U,4)=STRP
102 K STRP
103 I NUM>4 D ; if max segments exceeded fix here
104 . N BEG,END,STR,TMP
105 . F I=1:1:NUM S STR(I)=$P(WPAR(I),U,4)
106 . F I=1:1:(NUM-1) S TMP=132-$L(STR(I)) I TMP D
107 .. S END=$E(STR(I),$L(STR(I))),BEG=$E(STR(I+1))
108 .. ; put a blank in if needed
109 .. I $A(END)'=32,$A(BEG)'=32 S STR(I)=STR(I)_" ",TMP=TMP-1
110 .. S STR(I)=STR(I)_$E(STR(I+1),1,TMP)
111 .. S STR(I+1)=$E(STR(I+1),(TMP+1),$L(STR(I+1)))
112 .. I $L(STR(I)) S $P(WPAR(I),U,4)=STR(I)
113 .. I '$L(STR(I)) K WPAR(I)
114 . I '$L(STR(NUM)) K WPAR(NUM)
115 ; load temporary array into MESS array to load into Mailman message
116 S NSEG=$O(WPAR(""),-1)
117 S NUM=0 F S NUM=$O(WPAR(NUM)) Q:NUM="" D
118 . S OPX=WPAR(NUM),$P(OPX,U,3)=NSEG
119 . S ARR=ARR+1,MESS(ARR)=OPX
120 . S RSIZE=RSIZE+$L(OPX)+2
121 K ^UTILITY($J,"W"),X,OPFLD,NSEG
122 Q
Note: See TracBrowser for help on using the repository browser.