- BARPUC3 ; IHS/SD/LSL - UNALLOCATED COMMAND PROCESSING ; 07/16/2008
- ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,21,23***;OCT 26, 2005
- ;
- ; IHS/SD/SDR - 10/18/02 - V1.7 - OEA-1002-190010
- ; Resolve <UNDEF>PARSE+6^XBDIQ1
- ;
- ; IHS/SD/LSL - 12/24/02 - V1.7 - XJG-1202-160021
- ; Allow new adjustment categories 21 and 22
- ;
- ; *********************************************************************
- ; ;APR 2013 CONDITIONAL DISPLAY OF TXD AND MESSSAGES
- ;** 'Select Command' processor
- ;
- EN ;EP - command processor for unallocated
- K DIR,^TEMP($J,"BARPOST"),BARTR
- S (BARADJ,BARPMT)=0
- S BARDFLT=""
- W !!
- ; -------------------------------
- ;
- EN1 ;
- K BARCOM,BARTYP,BARCAT,BARATYP,BARAMT,BARLIN
- S BARDSP=1
- D HIT1^BARPUC2(BARPASS)
- ; -------------------------------
- ;
- EN2 ;
- W !!
- K BARCOM,BARAMT
- D:$D(BARHLP)<10 SETHLP^BARPUCU
- ; -------------------------------
- ;
- ASKLIN ;
- I BARCNT=1 S (BARLIN,BARDFLT)=1 G ASKCOM1
- D ASKLIN^BARFPST3
- I $G(BARLIN)["^" G FINISH
- I $G(BARLIN)=0 G FINISH
- I BARLIN>0,BARLIN<(BARCNT+1) G ASKCOM1
- ; -------------------------------
- ;
- LNHLP ;
- ;
- ASKCOM ;EP - ask command
- K BARCOM,BARTYP,BARCAT,BARATYP,BARAMT
- S BARDSP=1
- D HIT1^BARPUC2(BARPASS)
- W !
- ; -------------------------------
- ;
- ASKCOM1 ;
- ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
- I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) Q ;IS SESSION STILL OPEN
- W !,"Select Command (Line # "_BARLIN_") : "
- R BARCOM:DTIME
- ;K DIR
- ;S DIR(0)="FAO"
- ;S DIR("A")="Select Command (Line # "_BARLIN_") "
- ;S DIR("T")=DTIME
- ;D ^DIR
- ;K DIR
- ;S BARCOM=$$UPC^BARUTL(X)
- S BARCOM=$$UPC^BARUTL(BARCOM)
- S Q=0
- F J=1:1 D Q:Q
- .S BARCOM(J)=$P(BARCOM,",",J)
- .Q:$L(BARCOM(J))
- .K BARCOM(J)
- .S J=J-1
- .S Q=1
- I 'J!($L($G(BARCOM(1)))=0) G ASKCOM
- I '$D(BARHLP(BARCOM(1))) G COMHLP
- I J=1,BARCOM(J)="M" D G ASKCOM
- .N DA,DIC,BARBLDA,BARACC
- .S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
- .S BARACC=$$GET1^DIQ(90050.01,BARBLDA,3,"I")
- .D EN^BARPST6(BARPAT,BARBLDA,BARACC)
- .Q
- I J=1,BARCOM(J)="T" D G ASKCOM
- .S Y=$$DSPLY^BARPUC4(BARLIN)
- .D EOP^BARUTL(1)
- I J=1,BARCOM(J)="H" D HISTORY^BARBAD3 G ASKCOM ;P.OTT
- .;S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
- .;D EN^BARPST5(BARBLDA)
- ; -------------------------------
- ;
- GOQ ;
- I J=1,BARCOM(J)="Q" G:BARCNT>1 EN1 G FINISH
- ; -------------------------------
- ;
- GOP ;
- I J=1,BARCOM(J)="P" S BARTYP="P" G ASKAMT
- I J=1,BARCOM(J)="1" S BARTYP="P" G ASKAMT
- ; -------------------------------
- ;
- GOA ;
- I J=1,BARCOM(J)="A" S BARTYP="A" G ASKAMT
- I J=1,BARCOM(J)="2" S BARTYP="A" G ASKAMT
- ; -------------------------------
- ;
- GOD ;
- I J=1,BARCOM(J)="D" D G ASKCOM
- . S DFN=BARPAT
- . D VIEWR^XBLM("START^AGFACE")
- ; -------------------------------
- ;
- GOB ;
- I J=1,BARCOM(J)="B" D G ASKCOM
- . S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
- . D DIQ^XBLM(90050.01,BARBLDA)
- I J=1,BARCOM(J)="E" G ^BARPUC4
- W *7," Sorry.. ["_BARHLP(BARCOM(1))_"] not active!"
- G ASKCOM
- ; *********************************************************************
- ;
- ASKAMT ;
- S (BARCAT,BARATYP)=""
- S BARASK=$S(BARTYP="P":"Payment ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
- S BARBAL=(BARTX(2)-$G(BARPMT))
- W !,BARASK
- I BARTYP="P" W $J(BARBAL,0,2)_"// "
- R X:DTIME
- I BARTYP="P",X="" S X=+BARBAL
- I BARTYP="P" S X=$$AMT^BARPUCU(X,0,BARBAL)
- I BARTYP="A" S X=$$AMT^BARPUCU(X)
- I X="^" G ASKCOM
- I X="?" W *7," Must be a valid number!" G ASKAMT
- S BARAMT=X
- I BARTYP="P" D G S1
- .S BARCAT=$O(^BAR(90052.01,"B","PAYMENT TYPE",""))
- ;
- ;** adjustment category/type dialog
- S DIC=90052.01
- S DIC(0)="AEMNQZ"
- S DIC("A")="Adjustment Category: "
- S DIC("S")="I Y=3!(Y=4)!(Y=13)!(Y=14)!(Y=15)!(Y=16)!(Y=20)!(Y=21)!(Y=22)"
- K DD,DO
- D ^DIC
- K DIC
- I +Y<0 W *7 K BARAMT W !! G ASKAMT
- S BARCAT=+Y
- S:BARCAT=16 BARAMT=-BARAMT
- S BARX=0,BARJ=0
- K BARATYP
- F S BARX=$O(^BARTBL("D",BARCAT,BARX)) Q:'BARX D Q:BARJ>1
- .S BARJ=BARJ+1
- .Q:BARJ>1
- .S BARATYP=BARX
- I BARJ=1,$G(BARATYP) G S1
- S DIC=90052.02
- S DIC(0)="AEMNQZ"
- S DIC("A")="Adjustment Type: "
- S DIC("S")="I $P(^(0),U,2)=BARCAT"
- K DD,DO
- D ^DIC
- K DIC
- I +Y<0 K BARAMT W *7,!! G ASKAMT
- S BARATYP=+Y
- ; -------------------------------
- ;
- S1 ;
- D SETTMP^BARPUC3A(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP)
- G ASKCOM
- ; *********************************************************************
- ;
- COMHLP ;
- D COMHLP^BARPUCU
- G ASKCOM1
- ; *********************************************************************
- ;
- FINISH ;
- I '$G(BARPMT)&('$G(BARADJ)) D CANCEL Q
- FIN S BARQ=$$POST() ;BAR*1.8*4 DD 4.1.7.2
- I BARQ="M" G EN1
- I BARQ="C" D CANCEL Q
- ;I BARQ="P" D Q ;REWRITTEN ;BAR*1.8*4 DD 4.1.7.2
- ;. D POSTTX^BARPUCU
- ;. D EN^BARROLL
- I BARQ="P" D POSTTX^BARPUCU ;BAR*1.8*4 DD 4.1.7.2
- ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
- I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) Q ;IS SESSION STILL OPEN
- I $G(BARSTOP)=1 G FIN
- D EN^BARROLL
- K ^BARTMP($J)
- Q
- ; -------------------------------
- ;
- POST() ;
- P1 ;
- D HIT1^BARPUC2(BARPASS)
- D EOP^BARUTL(2)
- ; -------------------------------
- ;
- PDIR ;
- K DIR
- S DIR(0)="SAO^P:POST TO A/R;M:MORE;C:CANCEL"
- S DIR("A")="Select Action (P/M/C): "
- D ^DIR
- K DIR
- I $D(DUOUT)!(Y="") W *7 G PDIR
- Q Y
- ; *********************************************************************
- ;
- CANCEL ;
- K ^BARTMP($J)
- K BARPMT,BARADJ,BARTR
- Q
- BARPUC3 ; IHS/SD/LSL - UNALLOCATED COMMAND PROCESSING ; 07/16/2008
- +1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,21,23***;OCT 26, 2005
- +2 ;
- +3 ; IHS/SD/SDR - 10/18/02 - V1.7 - OEA-1002-190010
- +4 ; Resolve <UNDEF>PARSE+6^XBDIQ1
- +5 ;
- +6 ; IHS/SD/LSL - 12/24/02 - V1.7 - XJG-1202-160021
- +7 ; Allow new adjustment categories 21 and 22
- +8 ;
- +9 ; *********************************************************************
- +10 ; ;APR 2013 CONDITIONAL DISPLAY OF TXD AND MESSSAGES
- +11 ;** 'Select Command' processor
- +12 ;
- EN ;EP - command processor for unallocated
- +1 KILL DIR,^TEMP($JOB,"BARPOST"),BARTR
- +2 SET (BARADJ,BARPMT)=0
- +3 SET BARDFLT=""
- +4 WRITE !!
- +5 ; -------------------------------
- +6 ;
- EN1 ;
- +1 KILL BARCOM,BARTYP,BARCAT,BARATYP,BARAMT,BARLIN
- +2 SET BARDSP=1
- +3 DO HIT1^BARPUC2(BARPASS)
- +4 ; -------------------------------
- +5 ;
- EN2 ;
- +1 WRITE !!
- +2 KILL BARCOM,BARAMT
- +3 IF $DATA(BARHLP)<10
- DO SETHLP^BARPUCU
- +4 ; -------------------------------
- +5 ;
- ASKLIN ;
- +1 IF BARCNT=1
- SET (BARLIN,BARDFLT)=1
- GOTO ASKCOM1
- +2 DO ASKLIN^BARFPST3
- +3 IF $GET(BARLIN)["^"
- GOTO FINISH
- +4 IF $GET(BARLIN)=0
- GOTO FINISH
- +5 IF BARLIN>0
- IF BARLIN<(BARCNT+1)
- GOTO ASKCOM1
- +6 ; -------------------------------
- +7 ;
- LNHLP ;
- +1 ;
- ASKCOM ;EP - ask command
- +1 KILL BARCOM,BARTYP,BARCAT,BARATYP,BARAMT
- +2 SET BARDSP=1
- +3 DO HIT1^BARPUC2(BARPASS)
- +4 WRITE !
- +5 ; -------------------------------
- +6 ;
- ASKCOM1 ;
- +1 ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
- +2 ;IS SESSION STILL OPEN
- IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))
- QUIT
- +3 WRITE !,"Select Command (Line # "_BARLIN_") : "
- +4 READ BARCOM:DTIME
- +5 ;K DIR
- +6 ;S DIR(0)="FAO"
- +7 ;S DIR("A")="Select Command (Line # "_BARLIN_") "
- +8 ;S DIR("T")=DTIME
- +9 ;D ^DIR
- +10 ;K DIR
- +11 ;S BARCOM=$$UPC^BARUTL(X)
- +12 SET BARCOM=$$UPC^BARUTL(BARCOM)
- +13 SET Q=0
- +14 FOR J=1:1
- Begin DoDot:1
- +15 SET BARCOM(J)=$PIECE(BARCOM,",",J)
- +16 IF $LENGTH(BARCOM(J))
- QUIT
- +17 KILL BARCOM(J)
- +18 SET J=J-1
- +19 SET Q=1
- End DoDot:1
- IF Q
- QUIT
- +20 IF 'J!($LENGTH($GET(BARCOM(1)))=0)
- GOTO ASKCOM
- +21 IF '$DATA(BARHLP(BARCOM(1)))
- GOTO COMHLP
- +22 IF J=1
- IF BARCOM(J)="M"
- Begin DoDot:1
- +23 NEW DA,DIC,BARBLDA,BARACC
- +24 SET BARBLDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))
- +25 SET BARACC=$$GET1^DIQ(90050.01,BARBLDA,3,"I")
- +26 DO EN^BARPST6(BARPAT,BARBLDA,BARACC)
- +27 QUIT
- End DoDot:1
- GOTO ASKCOM
- +28 IF J=1
- IF BARCOM(J)="T"
- Begin DoDot:1
- +29 SET Y=$$DSPLY^BARPUC4(BARLIN)
- +30 DO EOP^BARUTL(1)
- End DoDot:1
- GOTO ASKCOM
- +31 ;P.OTT
- IF J=1
- IF BARCOM(J)="H"
- DO HISTORY^BARBAD3
- GOTO ASKCOM
- +32 ;S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
- +33 ;D EN^BARPST5(BARBLDA)
- +34 ; -------------------------------
- +35 ;
- GOQ ;
- +1 IF J=1
- IF BARCOM(J)="Q"
- IF BARCNT>1
- GOTO EN1
- GOTO FINISH
- +2 ; -------------------------------
- +3 ;
- GOP ;
- +1 IF J=1
- IF BARCOM(J)="P"
- SET BARTYP="P"
- GOTO ASKAMT
- +2 IF J=1
- IF BARCOM(J)="1"
- SET BARTYP="P"
- GOTO ASKAMT
- +3 ; -------------------------------
- +4 ;
- GOA ;
- +1 IF J=1
- IF BARCOM(J)="A"
- SET BARTYP="A"
- GOTO ASKAMT
- +2 IF J=1
- IF BARCOM(J)="2"
- SET BARTYP="A"
- GOTO ASKAMT
- +3 ; -------------------------------
- +4 ;
- GOD ;
- +1 IF J=1
- IF BARCOM(J)="D"
- Begin DoDot:1
- +2 SET DFN=BARPAT
- +3 DO VIEWR^XBLM("START^AGFACE")
- End DoDot:1
- GOTO ASKCOM
- +4 ; -------------------------------
- +5 ;
- GOB ;
- +1 IF J=1
- IF BARCOM(J)="B"
- Begin DoDot:1
- +2 SET BARBLDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))
- +3 DO DIQ^XBLM(90050.01,BARBLDA)
- End DoDot:1
- GOTO ASKCOM
- +4 IF J=1
- IF BARCOM(J)="E"
- GOTO ^BARPUC4
- +5 WRITE *7," Sorry.. ["_BARHLP(BARCOM(1))_"] not active!"
- +6 GOTO ASKCOM
- +7 ; *********************************************************************
- +8 ;
- ASKAMT ;
- +1 SET (BARCAT,BARATYP)=""
- +2 SET BARASK=$SELECT(BARTYP="P":"Payment ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
- +3 SET BARBAL=(BARTX(2)-$GET(BARPMT))
- +4 WRITE !,BARASK
- +5 IF BARTYP="P"
- WRITE $JUSTIFY(BARBAL,0,2)_"// "
- +6 READ X:DTIME
- +7 IF BARTYP="P"
- IF X=""
- SET X=+BARBAL
- +8 IF BARTYP="P"
- SET X=$$AMT^BARPUCU(X,0,BARBAL)
- +9 IF BARTYP="A"
- SET X=$$AMT^BARPUCU(X)
- +10 IF X="^"
- GOTO ASKCOM
- +11 IF X="?"
- WRITE *7," Must be a valid number!"
- GOTO ASKAMT
- +12 SET BARAMT=X
- +13 IF BARTYP="P"
- Begin DoDot:1
- +14 SET BARCAT=$ORDER(^BAR(90052.01,"B","PAYMENT TYPE",""))
- End DoDot:1
- GOTO S1
- +15 ;
- +16 ;** adjustment category/type dialog
- +17 SET DIC=90052.01
- +18 SET DIC(0)="AEMNQZ"
- +19 SET DIC("A")="Adjustment Category: "
- +20 SET DIC("S")="I Y=3!(Y=4)!(Y=13)!(Y=14)!(Y=15)!(Y=16)!(Y=20)!(Y=21)!(Y=22)"
- +21 KILL DD,DO
- +22 DO ^DIC
- +23 KILL DIC
- +24 IF +Y<0
- WRITE *7
- KILL BARAMT
- WRITE !!
- GOTO ASKAMT
- +25 SET BARCAT=+Y
- +26 IF BARCAT=16
- SET BARAMT=-BARAMT
- +27 SET BARX=0
- SET BARJ=0
- +28 KILL BARATYP
- +29 FOR
- SET BARX=$ORDER(^BARTBL("D",BARCAT,BARX))
- IF 'BARX
- QUIT
- Begin DoDot:1
- +30 SET BARJ=BARJ+1
- +31 IF BARJ>1
- QUIT
- +32 SET BARATYP=BARX
- End DoDot:1
- IF BARJ>1
- QUIT
- +33 IF BARJ=1
- IF $GET(BARATYP)
- GOTO S1
- +34 SET DIC=90052.02
- +35 SET DIC(0)="AEMNQZ"
- +36 SET DIC("A")="Adjustment Type: "
- +37 SET DIC("S")="I $P(^(0),U,2)=BARCAT"
- +38 KILL DD,DO
- +39 DO ^DIC
- +40 KILL DIC
- +41 IF +Y<0
- KILL BARAMT
- WRITE *7,!!
- GOTO ASKAMT
- +42 SET BARATYP=+Y
- +43 ; -------------------------------
- +44 ;
- S1 ;
- +1 DO SETTMP^BARPUC3A(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP)
- +2 GOTO ASKCOM
- +3 ; *********************************************************************
- +4 ;
- COMHLP ;
- +1 DO COMHLP^BARPUCU
- +2 GOTO ASKCOM1
- +3 ; *********************************************************************
- +4 ;
- FINISH ;
- +1 IF '$GET(BARPMT)&('$GET(BARADJ))
- DO CANCEL
- QUIT
- FIN ;BAR*1.8*4 DD 4.1.7.2
- SET BARQ=$$POST()
- +1 IF BARQ="M"
- GOTO EN1
- +2 IF BARQ="C"
- DO CANCEL
- QUIT
- +3 ;I BARQ="P" D Q ;REWRITTEN ;BAR*1.8*4 DD 4.1.7.2
- +4 ;. D POSTTX^BARPUCU
- +5 ;. D EN^BARROLL
- +6 ;BAR*1.8*4 DD 4.1.7.2
- IF BARQ="P"
- DO POSTTX^BARPUCU
- +7 ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
- +8 ;IS SESSION STILL OPEN
- IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))
- QUIT
- +9 IF $GET(BARSTOP)=1
- GOTO FIN
- +10 DO EN^BARROLL
- +11 KILL ^BARTMP($JOB)
- +12 QUIT
- +13 ; -------------------------------
- +14 ;
- POST() ;
- P1 ;
- +1 DO HIT1^BARPUC2(BARPASS)
- +2 DO EOP^BARUTL(2)
- +3 ; -------------------------------
- +4 ;
- PDIR ;
- +1 KILL DIR
- +2 SET DIR(0)="SAO^P:POST TO A/R;M:MORE;C:CANCEL"
- +3 SET DIR("A")="Select Action (P/M/C): "
- +4 DO ^DIR
- +5 KILL DIR
- +6 IF $DATA(DUOUT)!(Y="")
- WRITE *7
- GOTO PDIR
- +7 QUIT Y
- +8 ; *********************************************************************
- +9 ;
- CANCEL ;
- +1 KILL ^BARTMP($JOB)
- +2 KILL BARPMT,BARADJ,BARTR
- +3 QUIT
