- 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 Jan 18, 2025@02:40:03 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)