- RCDPDPLM ;WISC/RFJ - deposit profile listmanager top routine ;1 Jun 99
- ;;4.5;Accounts Receivable;**114,149,304**;Mar 20, 1995;Build 104
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- N RCDEPTDA,RCDPFXIT
- ;
- F D Q:'RCDEPTDA
- . W !! S RCDEPTDA=$$PREPDEPT^RCDPUDEP() ; PRCA*4.5*304 allow adding new deposit
- . I RCDEPTDA<1 S RCDEPTDA=0 Q
- . D EN^VALM("RCDP DEPOSIT PROFILE")
- . ; fast exit
- . I $G(RCDPFXIT) S RCDEPTDA=0
- Q
- ;
- ;
- INIT ; initialization for list manager list
- N COMMDA,FMSDOC,RCDEPCNT,RCDEPTOT,RCDPDATA,RCLINE,RCRECTDA,STATUS
- K ^TMP("RCDPDPLM",$J),^TMP("VALM VIDEO",$J)
- ;
- ; fast exit
- I $G(RCDPFXIT) S VALMQUIT=1 Q
- ;
- ; set the listmanager line number
- S RCLINE=0
- ;
- S RCRECTDA=0 F S RCRECTDA=$O(^RCY(344,"AD",RCDEPTDA,RCRECTDA)) Q:'RCRECTDA D
- . D DIQ344^RCDPRPLM(RCRECTDA,".01:999;")
- . S RCLINE=RCLINE+1
- . ; create an index array for bill lookup in list
- . S ^TMP("RCDPDPLM",$J,"IDX",RCLINE,RCLINE)=RCRECTDA
- . D SET(RCLINE,RCLINE,1,80,0,IORVON,IORVOFF)
- . ; receipt
- . D SET("",RCLINE,5,18,.01) ;PRCA*4.5*304
- . ; type of payment
- . D SET("",RCLINE,19,36,.04) ;PRCA*4.5*304
- . ; date opened
- . I RCDPDATA(344,RCRECTDA,.03,"I") D
- . . D SET($E(RCDPDATA(344,RCRECTDA,.03,"I"),4,5)_"/"_$E(RCDPDATA(344,RCRECTDA,.03,"I"),6,7)_"/"_$E(RCDPDATA(344,RCRECTDA,.03,"I"),2,3),RCLINE,37,44)
- . ; by (check for null before calling set)
- . I RCDPDATA(344,RCRECTDA,.02,"E")'="" D
- . . S X=$E($P(RCDPDATA(344,RCRECTDA,.02,"E"),",",2))_$E(RCDPDATA(344,RCRECTDA,.02,"E"))
- . . I RCDPDATA(344,RCRECTDA,.02,"I")=.5 S X="ar"
- . . D SET(X,RCLINE,46,47)
- . ; date processed
- . I RCDPDATA(344,RCRECTDA,.08,"I") D
- . . D SET($E(RCDPDATA(344,RCRECTDA,.08,"I"),4,5)_"/"_$E(RCDPDATA(344,RCRECTDA,.08,"I"),6,7)_"/"_$E(RCDPDATA(344,RCRECTDA,.08,"I"),2,3),RCLINE,49,56)
- . ; by (check for null before calling set)
- . I RCDPDATA(344,RCRECTDA,.07,"E")'="" D
- . . S X=$E($P(RCDPDATA(344,RCRECTDA,.07,"E"),",",2))_$E(RCDPDATA(344,RCRECTDA,.07,"E"))
- . . I RCDPDATA(344,RCRECTDA,.07,"I")=.5 S X="ar"
- . . D SET(X,RCLINE,59,60)
- . ; number of transactions
- . D SET($J(RCDPDATA(344,RCRECTDA,101,"E"),8),RCLINE,61,69)
- . ; total dollars
- . D SET($J(RCDPDATA(344,RCRECTDA,.15,"E"),10,2),RCLINE,70,79)
- . ; calculate totals
- . S RCDEPCNT=$G(RCDEPCNT)+RCDPDATA(344,RCRECTDA,101,"E")
- . S RCDEPTOT=$G(RCDEPTOT)+RCDPDATA(344,RCRECTDA,.15,"E")
- . K RCDPDATA
- ;
- I RCLINE=0 S RCLINE=RCLINE+1 D SET(" *** No RECEIPTS for this deposit ***",RCLINE,1,80)
- ;
- ; show totals
- S RCLINE=RCLINE+1
- D SET(" -------- --------",RCLINE,1,80)
- S RCLINE=RCLINE+1
- D SET(" TOTAL DOLLARS FOR DEPOSIT",RCLINE,1,80)
- D SET($J($G(RCDEPCNT),8),RCLINE,61,69)
- D SET($J($G(RCDEPTOT),10,2),RCLINE,70,79)
- ;
- ; deposit data displayed on screen
- D DIQ3441(RCDEPTDA,".01:1")
- S RCLINE=RCLINE+1 D SET(" ",RCLINE,1,80)
- S RCLINE=RCLINE+1 D SET(" Bank: "_RCDPDATA(344.1,RCDEPTDA,.13,"E"),RCLINE,1,80)
- S RCLINE=RCLINE+1 D SET(" Bank Trace Number: "_RCDPDATA(344.1,RCDEPTDA,.05,"E"),RCLINE,1,80)
- S RCLINE=RCLINE+1 D SET(" Agency Location Code: "_RCDPDATA(344.1,RCDEPTDA,.14,"E"),RCLINE,1,80)
- S RCLINE=RCLINE+1 D SET(" Agency Title: "_RCDPDATA(344.1,RCDEPTDA,.17,"E"),RCLINE,1,80)
- ;
- ; display comments if there are any
- I $O(^RCY(344.1,RCDEPTDA,1,0)) D
- . S RCLINE=RCLINE+1 D SET(" ",RCLINE,1,80)
- . S RCLINE=RCLINE+1 D SET("Comments",RCLINE,1,80,0,IOUON,IOUOFF)
- . S COMMDA=0 F S COMMDA=$O(^RCY(344.1,RCDEPTDA,1,COMMDA)) Q:'COMMDA D
- . . S RCLINE=RCLINE+1 D SET(^RCY(344.1,RCDEPTDA,1,COMMDA,0),RCLINE,1,80)
- ;
- ; display FMS CR documents if turned on
- I $G(^DISV(DUZ,"RCDPDPLM","SHOWFMS")) D
- . S RCLINE=RCLINE+1 D SET(" ",RCLINE,1,80)
- . S RCLINE=RCLINE+1 D SET("FMS CR Documents",RCLINE,1,80,0,IOUON,IOUOFF)
- . S RCRECTDA=0 F S RCRECTDA=$O(^RCY(344,"AD",RCDEPTDA,RCRECTDA)) Q:'RCRECTDA D
- . . D DIQ344^RCDPRPLM(RCRECTDA,".01;.14;")
- . . S FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
- . . S RCLINE=RCLINE+1
- . . D SET("",RCLINE,5,80,.01)
- . . D SET("",RCLINE,17,80,.14)
- . . D SET($P(FMSDOC,"^"),RCLINE,25,80)
- . . D SET($P(FMSDOC,"^",2),RCLINE,40,80)
- . . K RCDPDATA
- ;
- ; set valmcnt to number of lines in the list
- S VALMCNT=RCLINE
- Q
- ;
- ;
- SET(STRING,LINE,COLBEG,COLEND,FIELD,ON,OFF) ; set array
- I $G(FIELD) S STRING=STRING_$S(STRING="":"",1:": ")_$G(RCDPDATA(344,RCRECTDA,FIELD,"E"))
- I STRING="",'$G(FIELD) D SET^VALM10(LINE,$J("",80)) Q
- I '$D(@VALMAR@(LINE,0)) D SET^VALM10(LINE,$J("",80))
- D SET^VALM10(LINE,$$SETSTR^VALM1(STRING,@VALMAR@(LINE,0),COLBEG,COLEND-COLBEG+1))
- I $G(ON)]""!($G(OFF)]"") D CNTRL^VALM10(LINE,COLBEG,$L(STRING),ON,OFF)
- Q
- ;
- ;
- DIQ3441(DA,DR) ; diq call to retrieve data for dr fields in file 344.1
- N D0,DIC,DIQ,DIQ2,YY
- K RCDPDATA(344.1,DA)
- S DIQ(0)="IE",DIC="^RCY(344.1,",DIQ="RCDPDATA" D EN^DIQ1
- Q
- ;
- ;
- HDR ; header code for list manager display
- N DATE,RCDPDATA,SPACE
- D DIQ3441(RCDEPTDA,".01:1")
- S SPACE="",$P(SPACE," ",80)=""
- S VALMHDR(1)=$E(" Deposit #: "_RCDPDATA(344.1,RCDEPTDA,.01,"E")_SPACE,1,39)_" Deposit Status: "_RCDPDATA(344.1,RCDEPTDA,.12,"E")
- S VALMHDR(2)=$E("Deposit Date: "_RCDPDATA(344.1,RCDEPTDA,.03,"E")_SPACE,1,39)
- S DATE=RCDPDATA(344.1,RCDEPTDA,.07,"E"),DATE=$P(DATE,"@")_" "_$P($P(DATE,"@",2),":",1,2)
- I RCDPDATA(344.1,RCDEPTDA,.06,"I")=.5 S RCDPDATA(344.1,RCDEPTDA,.06,"E")="accounts receivable"
- S VALMHDR(3)=$E(" Opened By: "_RCDPDATA(344.1,RCDEPTDA,.06,"E")_SPACE,1,39)_"Date/Time Opened: "_DATE
- S DATE=RCDPDATA(344.1,RCDEPTDA,.11,"E"),DATE=$P(DATE,"@")_" "_$P($P(DATE,"@",2),":",1,2)
- I RCDPDATA(344.1,RCDEPTDA,.1,"I")=.5 S RCDPDATA(344.1,RCDEPTDA,.1,"E")="accounts receivable"
- S VALMHDR(4)=$E("Confirmed By: "_RCDPDATA(344.1,RCDEPTDA,.1,"E")_SPACE,1,39)_"Date/Time Confirmed: "_DATE
- ;
- I RCDPDATA(344.1,RCDEPTDA,.11,"I") S VALMSG="Deposit confirmed on "_RCDPDATA(344.1,RCDEPTDA,.11,"E")
- Q
- ;
- ;
- EXIT ; exit list manager option and clean up
- K ^TMP("RCDPDPLM",$J)
- Q
- ;
- ;
- FASTEXIT ; this is called by the protocol file to exit any of the deposit
- ; processing listmanager screens
- N DIR,DIQ2,DTOUT,DUOUT,X,Y
- ;
- S DIR(0)="YO",DIR("B")="NO"
- S DIR("A")=" Exit option entirely"
- D ^DIR
- I $G(DTOUT)!($G(DUOUT)) S Y=-1
- I $G(DIRUT)!(Y) S RCDPFXIT=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPDPLM 6535 printed Jan 18, 2025@02:45:15 Page 2
- RCDPDPLM ;WISC/RFJ - deposit profile listmanager top routine ;1 Jun 99
- +1 ;;4.5;Accounts Receivable;**114,149,304**;Mar 20, 1995;Build 104
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 NEW RCDEPTDA,RCDPFXIT
- +5 ;
- +6 FOR
- Begin DoDot:1
- +7 ; PRCA*4.5*304 allow adding new deposit
- WRITE !!
- SET RCDEPTDA=$$PREPDEPT^RCDPUDEP()
- +8 IF RCDEPTDA<1
- SET RCDEPTDA=0
- QUIT
- +9 DO EN^VALM("RCDP DEPOSIT PROFILE")
- +10 ; fast exit
- +11 IF $GET(RCDPFXIT)
- SET RCDEPTDA=0
- End DoDot:1
- if 'RCDEPTDA
- QUIT
- +12 QUIT
- +13 ;
- +14 ;
- INIT ; initialization for list manager list
- +1 NEW COMMDA,FMSDOC,RCDEPCNT,RCDEPTOT,RCDPDATA,RCLINE,RCRECTDA,STATUS
- +2 KILL ^TMP("RCDPDPLM",$JOB),^TMP("VALM VIDEO",$JOB)
- +3 ;
- +4 ; fast exit
- +5 IF $GET(RCDPFXIT)
- SET VALMQUIT=1
- QUIT
- +6 ;
- +7 ; set the listmanager line number
- +8 SET RCLINE=0
- +9 ;
- +10 SET RCRECTDA=0
- FOR
- SET RCRECTDA=$ORDER(^RCY(344,"AD",RCDEPTDA,RCRECTDA))
- if 'RCRECTDA
- QUIT
- Begin DoDot:1
- +11 DO DIQ344^RCDPRPLM(RCRECTDA,".01:999;")
- +12 SET RCLINE=RCLINE+1
- +13 ; create an index array for bill lookup in list
- +14 SET ^TMP("RCDPDPLM",$JOB,"IDX",RCLINE,RCLINE)=RCRECTDA
- +15 DO SET(RCLINE,RCLINE,1,80,0,IORVON,IORVOFF)
- +16 ; receipt
- +17 ;PRCA*4.5*304
- DO SET("",RCLINE,5,18,.01)
- +18 ; type of payment
- +19 ;PRCA*4.5*304
- DO SET("",RCLINE,19,36,.04)
- +20 ; date opened
- +21 IF RCDPDATA(344,RCRECTDA,.03,"I")
- Begin DoDot:2
- +22 DO SET($EXTRACT(RCDPDATA(344,RCRECTDA,.03,"I"),4,5)_"/"_$EXTRACT(RCDPDATA(344,RCRECTDA,.03,"I"),6,7)_"/"_$EXTRACT(RCDPDATA(344,RCRECTDA,.03,"I"),2,3),RCLINE,37,44)
- End DoDot:2
- +23 ; by (check for null before calling set)
- +24 IF RCDPDATA(344,RCRECTDA,.02,"E")'=""
- Begin DoDot:2
- +25 SET X=$EXTRACT($PIECE(RCDPDATA(344,RCRECTDA,.02,"E"),",",2))_$EXTRACT(RCDPDATA(344,RCRECTDA,.02,"E"))
- +26 IF RCDPDATA(344,RCRECTDA,.02,"I")=.5
- SET X="ar"
- +27 DO SET(X,RCLINE,46,47)
- End DoDot:2
- +28 ; date processed
- +29 IF RCDPDATA(344,RCRECTDA,.08,"I")
- Begin DoDot:2
- +30 DO SET($EXTRACT(RCDPDATA(344,RCRECTDA,.08,"I"),4,5)_"/"_$EXTRACT(RCDPDATA(344,RCRECTDA,.08,"I"),6,7)_"/"_$EXTRACT(RCDPDATA(344,RCRECTDA,.08,"I"),2,3),RCLINE,49,56)
- End DoDot:2
- +31 ; by (check for null before calling set)
- +32 IF RCDPDATA(344,RCRECTDA,.07,"E")'=""
- Begin DoDot:2
- +33 SET X=$EXTRACT($PIECE(RCDPDATA(344,RCRECTDA,.07,"E"),",",2))_$EXTRACT(RCDPDATA(344,RCRECTDA,.07,"E"))
- +34 IF RCDPDATA(344,RCRECTDA,.07,"I")=.5
- SET X="ar"
- +35 DO SET(X,RCLINE,59,60)
- End DoDot:2
- +36 ; number of transactions
- +37 DO SET($JUSTIFY(RCDPDATA(344,RCRECTDA,101,"E"),8),RCLINE,61,69)
- +38 ; total dollars
- +39 DO SET($JUSTIFY(RCDPDATA(344,RCRECTDA,.15,"E"),10,2),RCLINE,70,79)
- +40 ; calculate totals
- +41 SET RCDEPCNT=$GET(RCDEPCNT)+RCDPDATA(344,RCRECTDA,101,"E")
- +42 SET RCDEPTOT=$GET(RCDEPTOT)+RCDPDATA(344,RCRECTDA,.15,"E")
- +43 KILL RCDPDATA
- End DoDot:1
- +44 ;
- +45 IF RCLINE=0
- SET RCLINE=RCLINE+1
- DO SET(" *** No RECEIPTS for this deposit ***",RCLINE,1,80)
- +46 ;
- +47 ; show totals
- +48 SET RCLINE=RCLINE+1
- +49 DO SET(" -------- --------",RCLINE,1,80)
- +50 SET RCLINE=RCLINE+1
- +51 DO SET(" TOTAL DOLLARS FOR DEPOSIT",RCLINE,1,80)
- +52 DO SET($JUSTIFY($GET(RCDEPCNT),8),RCLINE,61,69)
- +53 DO SET($JUSTIFY($GET(RCDEPTOT),10,2),RCLINE,70,79)
- +54 ;
- +55 ; deposit data displayed on screen
- +56 DO DIQ3441(RCDEPTDA,".01:1")
- +57 SET RCLINE=RCLINE+1
- DO SET(" ",RCLINE,1,80)
- +58 SET RCLINE=RCLINE+1
- DO SET(" Bank: "_RCDPDATA(344.1,RCDEPTDA,.13,"E"),RCLINE,1,80)
- +59 SET RCLINE=RCLINE+1
- DO SET(" Bank Trace Number: "_RCDPDATA(344.1,RCDEPTDA,.05,"E"),RCLINE,1,80)
- +60 SET RCLINE=RCLINE+1
- DO SET(" Agency Location Code: "_RCDPDATA(344.1,RCDEPTDA,.14,"E"),RCLINE,1,80)
- +61 SET RCLINE=RCLINE+1
- DO SET(" Agency Title: "_RCDPDATA(344.1,RCDEPTDA,.17,"E"),RCLINE,1,80)
- +62 ;
- +63 ; display comments if there are any
- +64 IF $ORDER(^RCY(344.1,RCDEPTDA,1,0))
- Begin DoDot:1
- +65 SET RCLINE=RCLINE+1
- DO SET(" ",RCLINE,1,80)
- +66 SET RCLINE=RCLINE+1
- DO SET("Comments",RCLINE,1,80,0,IOUON,IOUOFF)
- +67 SET COMMDA=0
- FOR
- SET COMMDA=$ORDER(^RCY(344.1,RCDEPTDA,1,COMMDA))
- if 'COMMDA
- QUIT
- Begin DoDot:2
- +68 SET RCLINE=RCLINE+1
- DO SET(^RCY(344.1,RCDEPTDA,1,COMMDA,0),RCLINE,1,80)
- End DoDot:2
- End DoDot:1
- +69 ;
- +70 ; display FMS CR documents if turned on
- +71 IF $GET(^DISV(DUZ,"RCDPDPLM","SHOWFMS"))
- Begin DoDot:1
- +72 SET RCLINE=RCLINE+1
- DO SET(" ",RCLINE,1,80)
- +73 SET RCLINE=RCLINE+1
- DO SET("FMS CR Documents",RCLINE,1,80,0,IOUON,IOUOFF)
- +74 SET RCRECTDA=0
- FOR
- SET RCRECTDA=$ORDER(^RCY(344,"AD",RCDEPTDA,RCRECTDA))
- if 'RCRECTDA
- QUIT
- Begin DoDot:2
- +75 DO DIQ344^RCDPRPLM(RCRECTDA,".01;.14;")
- +76 SET FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
- +77 SET RCLINE=RCLINE+1
- +78 DO SET("",RCLINE,5,80,.01)
- +79 DO SET("",RCLINE,17,80,.14)
- +80 DO SET($PIECE(FMSDOC,"^"),RCLINE,25,80)
- +81 DO SET($PIECE(FMSDOC,"^",2),RCLINE,40,80)
- +82 KILL RCDPDATA
- End DoDot:2
- End DoDot:1
- +83 ;
- +84 ; set valmcnt to number of lines in the list
- +85 SET VALMCNT=RCLINE
- +86 QUIT
- +87 ;
- +88 ;
- SET(STRING,LINE,COLBEG,COLEND,FIELD,ON,OFF) ; set array
- +1 IF $GET(FIELD)
- SET STRING=STRING_$SELECT(STRING="":"",1:": ")_$GET(RCDPDATA(344,RCRECTDA,FIELD,"E"))
- +2 IF STRING=""
- IF '$GET(FIELD)
- DO SET^VALM10(LINE,$JUSTIFY("",80))
- QUIT
- +3 IF '$DATA(@VALMAR@(LINE,0))
- DO SET^VALM10(LINE,$JUSTIFY("",80))
- +4 DO SET^VALM10(LINE,$$SETSTR^VALM1(STRING,@VALMAR@(LINE,0),COLBEG,COLEND-COLBEG+1))
- +5 IF $GET(ON)]""!($GET(OFF)]"")
- DO CNTRL^VALM10(LINE,COLBEG,$LENGTH(STRING),ON,OFF)
- +6 QUIT
- +7 ;
- +8 ;
- DIQ3441(DA,DR) ; diq call to retrieve data for dr fields in file 344.1
- +1 NEW D0,DIC,DIQ,DIQ2,YY
- +2 KILL RCDPDATA(344.1,DA)
- +3 SET DIQ(0)="IE"
- SET DIC="^RCY(344.1,"
- SET DIQ="RCDPDATA"
- DO EN^DIQ1
- +4 QUIT
- +5 ;
- +6 ;
- HDR ; header code for list manager display
- +1 NEW DATE,RCDPDATA,SPACE
- +2 DO DIQ3441(RCDEPTDA,".01:1")
- +3 SET SPACE=""
- SET $PIECE(SPACE," ",80)=""
- +4 SET VALMHDR(1)=$EXTRACT(" Deposit #: "_RCDPDATA(344.1,RCDEPTDA,.01,"E")_SPACE,1,39)_" Deposit Status: "_RCDPDATA(344.1,RCDEPTDA,.12,"E")
- +5 SET VALMHDR(2)=$EXTRACT("Deposit Date: "_RCDPDATA(344.1,RCDEPTDA,.03,"E")_SPACE,1,39)
- +6 SET DATE=RCDPDATA(344.1,RCDEPTDA,.07,"E")
- SET DATE=$PIECE(DATE,"@")_" "_$PIECE($PIECE(DATE,"@",2),":",1,2)
- +7 IF RCDPDATA(344.1,RCDEPTDA,.06,"I")=.5
- SET RCDPDATA(344.1,RCDEPTDA,.06,"E")="accounts receivable"
- +8 SET VALMHDR(3)=$EXTRACT(" Opened By: "_RCDPDATA(344.1,RCDEPTDA,.06,"E")_SPACE,1,39)_"Date/Time Opened: "_DATE
- +9 SET DATE=RCDPDATA(344.1,RCDEPTDA,.11,"E")
- SET DATE=$PIECE(DATE,"@")_" "_$PIECE($PIECE(DATE,"@",2),":",1,2)
- +10 IF RCDPDATA(344.1,RCDEPTDA,.1,"I")=.5
- SET RCDPDATA(344.1,RCDEPTDA,.1,"E")="accounts receivable"
- +11 SET VALMHDR(4)=$EXTRACT("Confirmed By: "_RCDPDATA(344.1,RCDEPTDA,.1,"E")_SPACE,1,39)_"Date/Time Confirmed: "_DATE
- +12 ;
- +13 IF RCDPDATA(344.1,RCDEPTDA,.11,"I")
- SET VALMSG="Deposit confirmed on "_RCDPDATA(344.1,RCDEPTDA,.11,"E")
- +14 QUIT
- +15 ;
- +16 ;
- EXIT ; exit list manager option and clean up
- +1 KILL ^TMP("RCDPDPLM",$JOB)
- +2 QUIT
- +3 ;
- +4 ;
- FASTEXIT ; this is called by the protocol file to exit any of the deposit
- +1 ; processing listmanager screens
- +2 NEW DIR,DIQ2,DTOUT,DUOUT,X,Y
- +3 ;
- +4 SET DIR(0)="YO"
- SET DIR("B")="NO"
- +5 SET DIR("A")=" Exit option entirely"
- +6 DO ^DIR
- +7 IF $GET(DTOUT)!($GET(DUOUT))
- SET Y=-1
- +8 IF $GET(DIRUT)!(Y)
- SET RCDPFXIT=1
- +9 QUIT