OOPSDOLX ;WIOFO/CAH-Extract data for DOL XMIT ;3/15/00
;;2.0;ASISTS;**8,11,17**;Jun 03, 2002;Build 2
;
;Retrieves data from ^OOPS(2260, for CA1/CA2
;Variables used
; OOPDA-----IEN of Case
; OOPSAR----Array holding data
; OPL-------Last line number written in message text
; XMZ-------Message Number
; Entry
N ARR,KK,FN,FORM,MESS,NAME,OPC,OPSAR,OPT,OPX,SEG,OOPSAR,FYM,MON
S RSIZE=0,ARR=0
S OOPSAR(0)=$$UP^OOPSUTL4($G(^OOPS(2260,OOPDA,0)))
S OOPSAR("2162A")=$$UP^OOPSUTL4($G(^OOPS(2260,OOPDA,"2162A")))
S OOPSAR("2162B")=$$UP^OOPSUTL4($G(^OOPS(2260,OOPDA,"2162B")))
S OOPSAR("2162D")=$$UP^OOPSUTL4($G(^OOPS(2260,OOPDA,"2162D")))
S OOPSAR("2162ES")=$$UP^OOPSUTL4($G(^OOPS(2260,OOPDA,"2162ES")))
OP01 ; Seg OP01
K OPX,DTINJ
S OPX="OP01^"_$TR($P(OOPSAR(0),U),"-")
;V2_P15 - name fix to remove spaces and dashes
S NAME=$$NAMEFIX^OOPSDOLX($P(OOPSAR(0),U,2))
S OPX=OPX_U_$E($P(NAME,U,1)_","_$P(NAME,U,2)_" "_$P(NAME,U,3),1,35)
S OPX=OPX_U_$P(OOPSAR(0),U,7)_U_$TR($P(OOPSAR("2162A"),U),"-")
; patch 11 - send field 109 if CA1, field 214 if CA2
; left old code, commented below
S FORM=$$GET1^DIQ(2260,OOPDA,52,"I")
I FORM=1 D
. S DTINJ=$$GET1^DIQ(2260,OOPDA,109,"I")
. S OPX=OPX_U_$$DC^OOPSUTL3($P(DTINJ,"."))
. S Y=DTINJ D DD^%DT S Y=$P($TR(Y,":",""),"@",2),OPX=OPX_U_Y
I FORM=2 D
. S DTINJ=$$GET1^DIQ(2260,OOPDA,214,"I")
. S OPX=OPX_U_$$DC^OOPSUTL3($P(DTINJ,"."))_U
K DTINJ
;
; S OPX=OPX_U_$$DC^OOPSUTL3($P($P(OOPSAR(0),U,5),"."))
; I $$GET1^DIQ(2260,OOPDA,52,"I")=1 D
; .S Y=$P(OOPSAR(0),U,5) D DD^%DT S Y=$P($TR(Y,":",""),"@",2)
; .S OPX=OPX_U_Y
; I $$GET1^DIQ(2260,OOPDA,52,"I")=2 S OPX=OPX_U
S MON=$E($P(OOPSAR(0),U,5),4,5)
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)
S OPX=OPX_U_$E($P(OOPSAR(0),U),1,4)_U_$E("00",$L(FYM)+1,2)_FYM
;V2_P15 - name fix to remove spaces and dashes (have name from above)
S OPX=OPX_U_$P(NAME,U,1)_U_$P(NAME,U,2)_U_$P(NAME,U,3)
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)
S OPX=OPX_U_$TR($P(OOPSAR("2162A"),U,8),"(,)-^*/# ")
S OPX=OPX_U_$E($$GET1^DIQ(2260,OOPDA,7,"E"))_U_$$DC^OOPSUTL3($P(OOPSAR("2162A"),U,2))
; Patch 5 llh - changed next line from "70:.01" to 331
S OPX=OPX_U_$$GET1^DIQ(2260,OOPDA,331)
S OPX=OPX_"^^"_$P(OOPSAR("2162A"),U,10)_"^|"
D STORE
I $P(OOPSAR(0),U,7)=1 D ^OOPSDOL1
I $P(OOPSAR(0),U,7)=2 D ^OOPSDOL2
EXIT ; Loads the message and Quits the routine
I RSIZE+MSIZE>30000 D
.S END=$P($P(^OOPS(2260,OPAST,0),U),"-",2)
.D SEND^OOPSDOL,CREATE^OOPSDOL
.S (START,END)=""
F I=1:1:ARR I $G(MESS(I))'="" D
.S OPL=OPL+1,^XMB(3.9,XMZ,2,OPL,0)=MESS(I)
.I START="" S START=$P($P(OOPSAR(0),U),"-",2)
S MSIZE=MSIZE+RSIZE
K ARR,MESS,OPDT,RSIZE
Q
STORE ;
S ARR=ARR+1,MESS(ARR)=OPX
S RSIZE=RSIZE+$L(OPX)+2
Q
WP ; Word Processing Fields
K OPX
N DIWL,DIWR,DIWF,OPGLB,OPNODE,X,OPI,NUM,WPAR,F332,F347
S NUM=0,OPI=0
K ^UTILITY($J,"W")
S DIWL=1,DIWR="",DIWF="|C132"
; Patch 5 llh - added logic to concatenate field 332 to WP field (165)
I OPFLD=165 D
.S F332=$$GET1^DIQ(2260,OOPDA,"332:1")
.I $G(F332)'="" S X=F332 D ^DIWP
.;v2 p11 - concatenate Reason for Dispute to fld 165 in block 36
.S F347=$$GET1^DIQ(2260,OOPDA,"347:.01")
.I $G(F347)'="" S X=F347 D ^DIWP
S OPNODE=$P($$GET1^DID(2260,OPFLD,"","GLOBAL SUBSCRIPT LOCATION"),";")
S OPI=0 F S OPI=$O(^OOPS(2260,OOPDA,OPNODE,OPI)) Q:'OPI S X=$G(^OOPS(2260,OOPDA,OPNODE,OPI,0)) D
. I $TR(X," ","")="" Q
. I X]"" D ^DIWP
S OPT=$G(^UTILITY($J,"W",1))+0
; If OPT=0 then no data in ^UTILITY($J,"W") so quit
I 'OPT Q
; Need to set up an array to see if max segments exceeded
I OPT S OPI=0 F OPC=1:1:OPT S OPI=$O(^UTILITY($J,"W",1,OPI)) Q:'OPI D
. S NUM=NUM+1
. S WPAR(NUM)=SEG_U_OPC_U_OPT_U_$$UP^OOPSUTL4($E(^UTILITY($J,"W",1,OPI,0),1,132))_"^|"
; Fileman puts spaces at end of last node - need to strip off.
S STRP=$P(WPAR(NUM),U,4)
F K=$L(STRP):-1:1 Q:$E(STRP,K)'=" " S STRP=$E(STRP,1,(K-1))
S $P(WPAR(NUM),U,4)=STRP
K STRP
I NUM>4 D ; if max segments exceeded fix here
. N BEG,END,STR,TMP
. F I=1:1:NUM S STR(I)=$P(WPAR(I),U,4)
. F I=1:1:(NUM-1) S TMP=132-$L(STR(I)) I TMP D
.. S END=$E(STR(I),$L(STR(I))),BEG=$E(STR(I+1))
.. ; put a blank in if needed
.. I $A(END)'=32,$A(BEG)'=32 S STR(I)=STR(I)_" ",TMP=TMP-1
.. S STR(I)=STR(I)_$E(STR(I+1),1,TMP)
.. S STR(I+1)=$E(STR(I+1),(TMP+1),$L(STR(I+1)))
.. I $L(STR(I)) S $P(WPAR(I),U,4)=STR(I)
.. I '$L(STR(I)) K WPAR(I)
. I '$L(STR(NUM)) K WPAR(NUM)
; load temporary array into MESS array to load into Mailman message
S NSEG=$O(WPAR(""),-1)
S NUM=0 F S NUM=$O(WPAR(NUM)) Q:NUM="" D
. S OPX=WPAR(NUM),$P(OPX,U,3)=NSEG
. S ARR=ARR+1,MESS(ARR)=OPX
. S RSIZE=RSIZE+$L(OPX)+2
K ^UTILITY($J,"W"),X,OPFLD,NSEG
Q
NAMEFIX(NAME) ; strips dashes and spaces out of name and returns it in
; the format lastname, firstname middleinitial
;
; Input: Name - name in the format LN, FN MI
; Output: Name - name in the format LN, FN MI with embedded spaces
; and dashes removed
I $G(NAME)="" Q ""
N FN,KK,LN,MI
S LN=$P($TR(NAME,"- ",""),","),FN=$P($TR(NAME,"-",""),",",2)
; remove any leading spaces
F KK=1:0:1 Q:$E(LN,KK)'=" " S LN=$E(LN,KK+1,$L(LN))
F KK=1:0:1 Q:$E(FN,KK)'=" " S FN=$E(FN,KK+1,$L(FN))
I $L(FN," ")=1 S MI=""
I $L(FN," ")=2 D
.S FN=$P(FN," "),MI=$P(FN," ",2)
;how to collaspe first and middle names with extra spaces is
;totally arbitary - no way to know which spaces go w/which name
I $L(FN," ")>2 D
.S MI=$TR($P(FN," ",3,$L(FN," "))," ","")
.S FN=$TR($P(FN," ",1,2)," ","")
Q $E(LN,1,20)_U_$E(FN,1,10)_U_$E(MI,1,10)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOOPSDOLX 5836 printed Apr 09, 2024@20:44:13 Page 2
OOPSDOLX ;WIOFO/CAH-Extract data for DOL XMIT ;3/15/00
+1 ;;2.0;ASISTS;**8,11,17**;Jun 03, 2002;Build 2
+2 ;
+3 ;Retrieves data from ^OOPS(2260, for CA1/CA2
+4 ;Variables used
+5 ; OOPDA-----IEN of Case
+6 ; OOPSAR----Array holding data
+7 ; OPL-------Last line number written in message text
+8 ; XMZ-------Message Number
+9 ; Entry
+10 NEW ARR,KK,FN,FORM,MESS,NAME,OPC,OPSAR,OPT,OPX,SEG,OOPSAR,FYM,MON
+11 SET RSIZE=0
SET ARR=0
+12 SET OOPSAR(0)=$$UP^OOPSUTL4($GET(^OOPS(2260,OOPDA,0)))
+13 SET OOPSAR("2162A")=$$UP^OOPSUTL4($GET(^OOPS(2260,OOPDA,"2162A")))
+14 SET OOPSAR("2162B")=$$UP^OOPSUTL4($GET(^OOPS(2260,OOPDA,"2162B")))
+15 SET OOPSAR("2162D")=$$UP^OOPSUTL4($GET(^OOPS(2260,OOPDA,"2162D")))
+16 SET OOPSAR("2162ES")=$$UP^OOPSUTL4($GET(^OOPS(2260,OOPDA,"2162ES")))
OP01 ; Seg OP01
+1 KILL OPX,DTINJ
+2 SET OPX="OP01^"_$TRANSLATE($PIECE(OOPSAR(0),U),"-")
+3 ;V2_P15 - name fix to remove spaces and dashes
+4 SET NAME=$$NAMEFIX^OOPSDOLX($PIECE(OOPSAR(0),U,2))
+5 SET OPX=OPX_U_$EXTRACT($PIECE(NAME,U,1)_","_$PIECE(NAME,U,2)_" "_$PIECE(NAME,U,3),1,35)
+6 SET OPX=OPX_U_$PIECE(OOPSAR(0),U,7)_U_$TRANSLATE($PIECE(OOPSAR("2162A"),U),"-")
+7 ; patch 11 - send field 109 if CA1, field 214 if CA2
+8 ; left old code, commented below
+9 SET FORM=$$GET1^DIQ(2260,OOPDA,52,"I")
+10 IF FORM=1
Begin DoDot:1
+11 SET DTINJ=$$GET1^DIQ(2260,OOPDA,109,"I")
+12 SET OPX=OPX_U_$$DC^OOPSUTL3($PIECE(DTINJ,"."))
+13 SET Y=DTINJ
DO DD^%DT
SET Y=$PIECE($TRANSLATE(Y,":",""),"@",2)
SET OPX=OPX_U_Y
End DoDot:1
+14 IF FORM=2
Begin DoDot:1
+15 SET DTINJ=$$GET1^DIQ(2260,OOPDA,214,"I")
+16 SET OPX=OPX_U_$$DC^OOPSUTL3($PIECE(DTINJ,"."))_U
End DoDot:1
+17 KILL DTINJ
+18 ;
+19 ; S OPX=OPX_U_$$DC^OOPSUTL3($P($P(OOPSAR(0),U,5),"."))
+20 ; I $$GET1^DIQ(2260,OOPDA,52,"I")=1 D
+21 ; .S Y=$P(OOPSAR(0),U,5) D DD^%DT S Y=$P($TR(Y,":",""),"@",2)
+22 ; .S OPX=OPX_U_Y
+23 ; I $$GET1^DIQ(2260,OOPDA,52,"I")=2 S OPX=OPX_U
+24 SET MON=$EXTRACT($PIECE(OOPSAR(0),U,5),4,5)
+25 SET FYM=$SELECT(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)
+26 SET OPX=OPX_U_$EXTRACT($PIECE(OOPSAR(0),U),1,4)_U_$EXTRACT("00",$LENGTH(FYM)+1,2)_FYM
+27 ;V2_P15 - name fix to remove spaces and dashes (have name from above)
+28 SET OPX=OPX_U_$PIECE(NAME,U,1)_U_$PIECE(NAME,U,2)_U_$PIECE(NAME,U,3)
+29 SET OPX=OPX_"^^"_$PIECE(OOPSAR("2162A"),U,4)_U_$PIECE(OOPSAR("2162A"),U,5)_U_$$GET1^DIQ(2260,OOPDA,"10:1")_U_$EXTRACT($PIECE(OOPSAR("2162A"),U,7),1,5)
+30 SET OPX=OPX_U_$TRANSLATE($PIECE(OOPSAR("2162A"),U,8),"(,)-^*/# ")
+31 SET OPX=OPX_U_$EXTRACT($$GET1^DIQ(2260,OOPDA,7,"E"))_U_$$DC^OOPSUTL3($PIECE(OOPSAR("2162A"),U,2))
+32 ; Patch 5 llh - changed next line from "70:.01" to 331
+33 SET OPX=OPX_U_$$GET1^DIQ(2260,OOPDA,331)
+34 SET OPX=OPX_"^^"_$PIECE(OOPSAR("2162A"),U,10)_"^|"
+35 DO STORE
+36 IF $PIECE(OOPSAR(0),U,7)=1
DO ^OOPSDOL1
+37 IF $PIECE(OOPSAR(0),U,7)=2
DO ^OOPSDOL2
EXIT ; Loads the message and Quits the routine
+1 IF RSIZE+MSIZE>30000
Begin DoDot:1
+2 SET END=$PIECE($PIECE(^OOPS(2260,OPAST,0),U),"-",2)
+3 DO SEND^OOPSDOL
DO CREATE^OOPSDOL
+4 SET (START,END)=""
End DoDot:1
+5 FOR I=1:1:ARR
IF $GET(MESS(I))'=""
Begin DoDot:1
+6 SET OPL=OPL+1
SET ^XMB(3.9,XMZ,2,OPL,0)=MESS(I)
+7 IF START=""
SET START=$PIECE($PIECE(OOPSAR(0),U),"-",2)
End DoDot:1
+8 SET MSIZE=MSIZE+RSIZE
+9 KILL ARR,MESS,OPDT,RSIZE
+10 QUIT
STORE ;
+1 SET ARR=ARR+1
SET MESS(ARR)=OPX
+2 SET RSIZE=RSIZE+$LENGTH(OPX)+2
+3 QUIT
WP ; Word Processing Fields
+1 KILL OPX
+2 NEW DIWL,DIWR,DIWF,OPGLB,OPNODE,X,OPI,NUM,WPAR,F332,F347
+3 SET NUM=0
SET OPI=0
+4 KILL ^UTILITY($JOB,"W")
+5 SET DIWL=1
SET DIWR=""
SET DIWF="|C132"
+6 ; Patch 5 llh - added logic to concatenate field 332 to WP field (165)
+7 IF OPFLD=165
Begin DoDot:1
+8 SET F332=$$GET1^DIQ(2260,OOPDA,"332:1")
+9 IF $GET(F332)'=""
SET X=F332
DO ^DIWP
+10 ;v2 p11 - concatenate Reason for Dispute to fld 165 in block 36
+11 SET F347=$$GET1^DIQ(2260,OOPDA,"347:.01")
+12 IF $GET(F347)'=""
SET X=F347
DO ^DIWP
End DoDot:1
+13 SET OPNODE=$PIECE($$GET1^DID(2260,OPFLD,"","GLOBAL SUBSCRIPT LOCATION"),";")
+14 SET OPI=0
FOR
SET OPI=$ORDER(^OOPS(2260,OOPDA,OPNODE,OPI))
if 'OPI
QUIT
SET X=$GET(^OOPS(2260,OOPDA,OPNODE,OPI,0))
Begin DoDot:1
+15 IF $TRANSLATE(X," ","")=""
QUIT
+16 IF X]""
DO ^DIWP
End DoDot:1
+17 SET OPT=$GET(^UTILITY($JOB,"W",1))+0
+18 ; If OPT=0 then no data in ^UTILITY($J,"W") so quit
+19 IF 'OPT
QUIT
+20 ; Need to set up an array to see if max segments exceeded
+21 IF OPT
SET OPI=0
FOR OPC=1:1:OPT
SET OPI=$ORDER(^UTILITY($JOB,"W",1,OPI))
if 'OPI
QUIT
Begin DoDot:1
+22 SET NUM=NUM+1
+23 SET WPAR(NUM)=SEG_U_OPC_U_OPT_U_$$UP^OOPSUTL4($EXTRACT(^UTILITY($JOB,"W",1,OPI,0),1,132))_"^|"
End DoDot:1
+24 ; Fileman puts spaces at end of last node - need to strip off.
+25 SET STRP=$PIECE(WPAR(NUM),U,4)
+26 FOR K=$LENGTH(STRP):-1:1
if $EXTRACT(STRP,K)'=" "
QUIT
SET STRP=$EXTRACT(STRP,1,(K-1))
+27 SET $PIECE(WPAR(NUM),U,4)=STRP
+28 KILL STRP
+29 ; if max segments exceeded fix here
IF NUM>4
Begin DoDot:1
+30 NEW BEG,END,STR,TMP
+31 FOR I=1:1:NUM
SET STR(I)=$PIECE(WPAR(I),U,4)
+32 FOR I=1:1:(NUM-1)
SET TMP=132-$LENGTH(STR(I))
IF TMP
Begin DoDot:2
+33 SET END=$EXTRACT(STR(I),$LENGTH(STR(I)))
SET BEG=$EXTRACT(STR(I+1))
+34 ; put a blank in if needed
+35 IF $ASCII(END)'=32
IF $ASCII(BEG)'=32
SET STR(I)=STR(I)_" "
SET TMP=TMP-1
+36 SET STR(I)=STR(I)_$EXTRACT(STR(I+1),1,TMP)
+37 SET STR(I+1)=$EXTRACT(STR(I+1),(TMP+1),$LENGTH(STR(I+1)))
+38 IF $LENGTH(STR(I))
SET $PIECE(WPAR(I),U,4)=STR(I)
+39 IF '$LENGTH(STR(I))
KILL WPAR(I)
End DoDot:2
+40 IF '$LENGTH(STR(NUM))
KILL WPAR(NUM)
End DoDot:1
+41 ; load temporary array into MESS array to load into Mailman message
+42 SET NSEG=$ORDER(WPAR(""),-1)
+43 SET NUM=0
FOR
SET NUM=$ORDER(WPAR(NUM))
if NUM=""
QUIT
Begin DoDot:1
+44 SET OPX=WPAR(NUM)
SET $PIECE(OPX,U,3)=NSEG
+45 SET ARR=ARR+1
SET MESS(ARR)=OPX
+46 SET RSIZE=RSIZE+$LENGTH(OPX)+2
End DoDot:1
+47 KILL ^UTILITY($JOB,"W"),X,OPFLD,NSEG
+48 QUIT
NAMEFIX(NAME) ; strips dashes and spaces out of name and returns it in
+1 ; the format lastname, firstname middleinitial
+2 ;
+3 ; Input: Name - name in the format LN, FN MI
+4 ; Output: Name - name in the format LN, FN MI with embedded spaces
+5 ; and dashes removed
+6 IF $GET(NAME)=""
QUIT ""
+7 NEW FN,KK,LN,MI
+8 SET LN=$PIECE($TRANSLATE(NAME,"- ",""),",")
SET FN=$PIECE($TRANSLATE(NAME,"-",""),",",2)
+9 ; remove any leading spaces
+10 FOR KK=1:0:1
if $EXTRACT(LN,KK)'=" "
QUIT
SET LN=$EXTRACT(LN,KK+1,$LENGTH(LN))
+11 FOR KK=1:0:1
if $EXTRACT(FN,KK)'=" "
QUIT
SET FN=$EXTRACT(FN,KK+1,$LENGTH(FN))
+12 IF $LENGTH(FN," ")=1
SET MI=""
+13 IF $LENGTH(FN," ")=2
Begin DoDot:1
+14 SET FN=$PIECE(FN," ")
SET MI=$PIECE(FN," ",2)
End DoDot:1
+15 ;how to collaspe first and middle names with extra spaces is
+16 ;totally arbitary - no way to know which spaces go w/which name
+17 IF $LENGTH(FN," ")>2
Begin DoDot:1
+18 SET MI=$TRANSLATE($PIECE(FN," ",3,$LENGTH(FN," "))," ","")
+19 SET FN=$TRANSLATE($PIECE(FN," ",1,2)," ","")
End DoDot:1
+20 QUIT $EXTRACT(LN,1,20)_U_$EXTRACT(FN,1,10)_U_$EXTRACT(MI,1,10)
