Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: OOPSDOLX

OOPSDOLX.m

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