- ACHSCHK ; IHS/ITSC/PMF - PRINT 638 CHECKS (1/2) ; [ 10/16/2001 8:16 AM ]
- ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
- ;
- S ACHSADJ=""
- D ^ACHSUSC ;SELECT DOCUMENT
- I '$D(ACHSDIEN) D K Q
- D G K:'$D(ACHSDIEN)
- ;
- I $$DOC^ACHS(2,2)>0 W *7,!!,"A CHECK HAS ALREADY BEEN PRINTED FOR THIS DOCUMENT" K ACHSDIEN Q
- ;
- ;QUIT IF 'STATUS'= "PAID" AND THERE IS A PAID AMOUNT RECORD
- I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,12)=3&($D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))) W *7,!!,"Not a paid document OR pay amount is 0." Q
- ;
- DEV ;
- W !
- S %ZIS="0P",%ZIS("A")="DEVICE for printing checks:",%ZIS("B")=""
- D ^%ZIS,SLV^ACHSFU:$D(IO("S"))
- ;
- I POP D K1 Q
- ;
- S ACHSCLEN=+$P($P($T(@"FORMAT"),";;"),";",2)
- ;
- F X:$D(IO("S")) ACHSPPC U IO(0) W !,"TEST CHECK POSITION ON THE PRINTER? " D READ^ACHSFU G K1:$D(DUOUT)!$D(DTOUT) Q:"Yy"'[$E(Y_"N") D TEST
- BCN ;
- X:$D(IO("S")) ACHSPPC
- S ACHSBCN=1,Y=0,Y=$O(^ACHSF(DUZ(2),"TCHK",Y))
- S:Y'="" ACHSBCN=(999999999-Y)+1
- U IO(0)
- W !!,"ENTER THE ",$S($D(ACHSBAT):"BEGINNING ",1:""),"CHECK NUMBER : ",ACHSBCN,"//"
- D READ^ACHSFU
- I $G(ACHSQUIT) D K1 Q
- G BCN1:Y=""
- I +Y<1 W *7," ??" G BCN
- ;
- ;CHECK THE 'CHECK #' X-REF
- I $D(^ACHSF(DUZ(2),"TCHK",999999999-Y)) W *7,!,"THIS CHECK NUMBER HAS ALREADY BEEN USED" G BCN
- S ACHSBCN=+Y
- BCN1 ;
- W " ",ACHSBCN,!!,"READY TO START? N// "
- D READ^ACHSFU
- I $G(ACHSQUIT) D K1 Q
- G DEV:$D(DUOUT)!("Yy"'[($E(Y_"N")))
- X:$D(IO("S")) ACHSPPO
- U IO
- S1 ;
- K ^UTILITY("DIQ1",$J)
- S ACHSLPOS=0
- F ACHS=1:1 S ACHSWORK=$T(@"FORMAT"+ACHS) Q:ACHSWORK="" D FMT,POSITION,VALUE
- F Q:ACHSLPOS=ACHSCLEN W ! S ACHSLPOS=ACHSLPOS+1
- S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,2),U,2)=ACHSBCN,$P(^(2),U,3)=DT
- S ^ACHSF(DUZ(2),"TCHK",999999999-ACHSBCN,ACHSDIEN)=""
- K ^ACHS(7,"CHS 638 CHECKS",DUZ(2),ACHSDIEN)
- I $D(ACHSBAT) F S ACHSDIEN=$O(^ACHS(7,"CHS 638 CHECKS",DUZ(2),ACHSDIEN)) Q:'ACHSDIEN I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,12)=3,+$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) D G S1
- . S ACHSBCN=ACHSBCN+1
- . F ACHSBCN=ACHSBCN:1 Q:'$D(^ACHSF(DUZ(2),"TCHK",999999999-ACHSBCN))
- ;
- K ;
- X:$D(IO("S")) ACHSPPC
- D ^%ZISC ;CLOSE ALL DEVICES
- K1 ;
- K ACHSDIEN,ACHSBAT,ACHSBCN,ACHSCLEN,ACHSCOL,ACHSLINE,ACHSLPOS,ACHSOT,ACHSPPC,ACHSPPO,ACHSWORK,DA,DIC,DR,D0,D1,^UTILITY("DIQ1",$J)
- Q
- ;
- FMT ;
- K DA,DIC,DR
- S ACHSLINE=$P(ACHSWORK,";;",2),ACHSCOL=$P(ACHSWORK,";;",3),DIC=$P(ACHSWORK,";;",4),ACHSOT=""
- I DIC S DR=$P(ACHSWORK,";;",5),DA=@($P(ACHSWORK,";;",6)) I $P(ACHSWORK,";;",7) S DR($P(ACHSWORK,";;",7))=$P(ACHSWORK,";;",8),DA($P(ACHSWORK,";;",7))=@($P(ACHSWORK,";;",9)),ACHSOT=$P(ACHSWORK,";;",10)
- Q
- ;
- POSITION ;
- F Q:ACHSLPOS=ACHSLINE W ! S ACHSLPOS=ACHSLPOS+1
- W:ACHSCOL ?ACHSCOL
- W:'ACHSCOL ACHSCOL
- Q
- ;
- VALUE ;
- I 'DIC X DIC Q
- I ACHSWORK["PAYAMT" D DOLLAR Q
- I ACHSWORK["PAYTXT" D DOLLAR1 Q
- ; Naked reference in next 2 lines from line S1 and set by indirection to lines FORMAT to FORMAT+12
- D EN^DIQ1
- I $P(ACHSWORK,";;",7)]"" S X=^($P(ACHSWORK,";;",8)) G VALUE2
- S X=^($P(ACHSWORK,";;",5))
- VALUE2 ;
- X:ACHSOT]"" ACHSOT
- W X
- Q
- ;
- DOLLAR ;
- S X=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),U),X3=1
- D COMMA^%DTC
- S X=$E("$$$$$$$$$$$$$",1,13-$L(X))_X
- K X3
- W X
- Q
- ;
- DOLLAR1 ;
- S X=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),U),X3=1
- D COMMA^%DTC,AMT^ACHSCHK1
- K X3
- W X
- Q
- ;
- TEST ;
- X:$D(IO("S")) ACHSPPO
- U IO
- S ACHSLPOS=0
- F ACHS=1:1:7 S ACHSWORK=$T(@"FORMAT"+ACHS) Q:ACHSWORK="" D FMT,POSITION W "######"
- F Q:ACHSLPOS=ACHSCLEN W ! S ACHSLPOS=ACHSLPOS+1
- Q
- ;
- BATCH ;EP - From option.
- I '$D(^ACHS(7,"CHS 638 CHECKS",DUZ(2))) W *7,!!,"NO CHECKS BATCHED TO PRINT." Q
- S ACHSDIEN=0
- F S ACHSDIEN=$O(^ACHS(7,"CHS 638 CHECKS",DUZ(2),ACHSDIEN)) G K:'ACHSDIEN Q:$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,12)=3&(+$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")))
- S ACHSPROV=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,8)
- S ACHSBAT=""
- G DEV
- ;
- FORMAT ;42;;line #;;col #;;file # or MUMPS code;;field #;;DA;;sub-file #;;sub-file field #;;DA(sub-file #);;OUTPUT TRANSFORM
- CHECK ;;2;;45;;W "CHECK #: ",$E(1000000000+ACHSBCN,2,10)
- PONUM ;;5;;25;;9002080;;100;;DUZ(2);;9002080.01;;.01;;ACHSDIEN
- PATIENT ;;5;;42;;9002080;;100;;DUZ(2);;9002080.01;;13.64;;ACHSDIEN
- PAYTXT ;;8;;5;;9002080;;100;;DUZ(2);;9002080.01;;15;;ACHSDIEN;;S X3=1 D COMMA^%DTC,AMT^ACHSCHK1 K X3
- DATE ;;9;;54;;W $$FMTE^XLFDT(DT)
- PAYAMT ;;10;;67;;9002080;;100;;DUZ(2);;9002080.01;;15;;ACHSDIEN;;S X3=1 D COMMA^%DTC S X=$E("$$$$$$$$$$$$$",1,13-$L(X))_X K X3
- PROVIDER ;;11;;8;;9002080;;100;;DUZ(2);;9002080.01;;7;;ACHSDIEN;;S:X["," X=$P(X,",",2)_" "_$P(X,",")
- PROVSTR ;;12;;8;;9999999.11;;1301;;ACHSPROV
- PROVCTY ;;13;;8;;9999999.11;;1302;;ACHSPROV
- PROVST ;;13;; ;;9999999.11;;1303;;ACHSPROV
- PROVZIP ;;13;; ;;9999999.11;;1304;;ACHSPROV
- SVCDATE ;;27;;1;;9002080;;100;;DUZ(2);;9002080.01;;75;;ACHSDIEN
- PONUM2 ;;28;;12;;9002080;;100;;DUZ(2);;9002080.01;;.01;;ACHSDIEN
- PATIENT2 ;;28;;26;;9002080;;100;;DUZ(2);;9002080.01;;13.64;;ACHSDIEN
- PAYAMT2 ;;28;;67;;9002080;;100;;DUZ(2);;9002080.01;;15;;ACHSDIEN;;S X3=1 D COMMA^%DTC S X=$E("$$$$$$$$$$$$$",1,13-$L(X))_X K X3
- PROV2 ;;29;;12;;9002080;;100;;DUZ(2);;9002080.01;;7;;ACHSDIEN;;S:X["," X=$P(X,",",2)_" "_$P(X,",")
- ACHSCHK ; IHS/ITSC/PMF - PRINT 638 CHECKS (1/2) ; [ 10/16/2001 8:16 AM ]
- +1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
- +2 ;
- +3 SET ACHSADJ=""
- +4 ;SELECT DOCUMENT
- DO ^ACHSUSC
- +5 IF '$DATA(ACHSDIEN)
- DO K
- QUIT
- +6 Begin DoDot:1
- End DoDot:1
- IF '$DATA(ACHSDIEN)
- GOTO K
- +7 ;
- +8 IF $$DOC^ACHS(2,2)>0
- WRITE *7,!!,"A CHECK HAS ALREADY BEEN PRINTED FOR THIS DOCUMENT"
- KILL ACHSDIEN
- QUIT
- +9 ;
- +10 ;QUIT IF 'STATUS'= "PAID" AND THERE IS A PAID AMOUNT RECORD
- +11 IF $PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,12)=3&($DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")))
- WRITE *7,!!,"Not a paid document OR pay amount is 0."
- QUIT
- +12 ;
- DEV ;
- +1 WRITE !
- +2 SET %ZIS="0P"
- SET %ZIS("A")="DEVICE for printing checks:"
- SET %ZIS("B")=""
- +3 DO ^%ZIS
- IF $DATA(IO("S"))
- DO SLV^ACHSFU
- +4 ;
- +5 IF POP
- DO K1
- QUIT
- +6 ;
- +7 SET ACHSCLEN=+$PIECE($PIECE($TEXT(@"FORMAT"),";;"),";",2)
- +8 ;
- +9 FOR
- IF $DATA(IO("S"))
- XECUTE ACHSPPC
- USE IO(0)
- WRITE !,"TEST CHECK POSITION ON THE PRINTER? "
- DO READ^ACHSFU
- IF $DATA(DUOUT)!$DATA(DTOUT)
- GOTO K1
- IF "Yy"'[$EXTRACT(Y_"N")
- QUIT
- DO TEST
- BCN ;
- +1 IF $DATA(IO("S"))
- XECUTE ACHSPPC
- +2 SET ACHSBCN=1
- SET Y=0
- SET Y=$ORDER(^ACHSF(DUZ(2),"TCHK",Y))
- +3 IF Y'=""
- SET ACHSBCN=(999999999-Y)+1
- +4 USE IO(0)
- +5 WRITE !!,"ENTER THE ",$SELECT($DATA(ACHSBAT):"BEGINNING ",1:""),"CHECK NUMBER : ",ACHSBCN,"//"
- +6 DO READ^ACHSFU
- +7 IF $GET(ACHSQUIT)
- DO K1
- QUIT
- +8 IF Y=""
- GOTO BCN1
- +9 IF +Y<1
- WRITE *7," ??"
- GOTO BCN
- +10 ;
- +11 ;CHECK THE 'CHECK #' X-REF
- +12 IF $DATA(^ACHSF(DUZ(2),"TCHK",999999999-Y))
- WRITE *7,!,"THIS CHECK NUMBER HAS ALREADY BEEN USED"
- GOTO BCN
- +13 SET ACHSBCN=+Y
- BCN1 ;
- +1 WRITE " ",ACHSBCN,!!,"READY TO START? N// "
- +2 DO READ^ACHSFU
- +3 IF $GET(ACHSQUIT)
- DO K1
- QUIT
- +4 IF $DATA(DUOUT)!("Yy"'[($EXTRACT(Y_"N")))
- GOTO DEV
- +5 IF $DATA(IO("S"))
- XECUTE ACHSPPO
- +6 USE IO
- S1 ;
- +1 KILL ^UTILITY("DIQ1",$JOB)
- +2 SET ACHSLPOS=0
- +3 FOR ACHS=1:1
- SET ACHSWORK=$TEXT(@"FORMAT"+ACHS)
- IF ACHSWORK=""
- QUIT
- DO FMT
- DO POSITION
- DO VALUE
- +4 FOR
- IF ACHSLPOS=ACHSCLEN
- QUIT
- WRITE !
- SET ACHSLPOS=ACHSLPOS+1
- +5 SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,2),U,2)=ACHSBCN
- SET $PIECE(^(2),U,3)=DT
- +6 SET ^ACHSF(DUZ(2),"TCHK",999999999-ACHSBCN,ACHSDIEN)=""
- +7 KILL ^ACHS(7,"CHS 638 CHECKS",DUZ(2),ACHSDIEN)
- +8 IF $DATA(ACHSBAT)
- FOR
- SET ACHSDIEN=$ORDER(^ACHS(7,"CHS 638 CHECKS",DUZ(2),ACHSDIEN))
- IF 'ACHSDIEN
- QUIT
- IF $PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,12)=3
- IF +$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))
- Begin DoDot:1
- +9 SET ACHSBCN=ACHSBCN+1
- +10 FOR ACHSBCN=ACHSBCN:1
- IF '$DATA(^ACHSF(DUZ(2),"TCHK",999999999-ACHSBCN))
- QUIT
- End DoDot:1
- GOTO S1
- +11 ;
- K ;
- +1 IF $DATA(IO("S"))
- XECUTE ACHSPPC
- +2 ;CLOSE ALL DEVICES
- DO ^%ZISC
- K1 ;
- +1 KILL ACHSDIEN,ACHSBAT,ACHSBCN,ACHSCLEN,ACHSCOL,ACHSLINE,ACHSLPOS,ACHSOT,ACHSPPC,ACHSPPO,ACHSWORK,DA,DIC,DR,D0,D1,^UTILITY("DIQ1",$JOB)
- +2 QUIT
- +3 ;
- FMT ;
- +1 KILL DA,DIC,DR
- +2 SET ACHSLINE=$PIECE(ACHSWORK,";;",2)
- SET ACHSCOL=$PIECE(ACHSWORK,";;",3)
- SET DIC=$PIECE(ACHSWORK,";;",4)
- SET ACHSOT=""
- +3 IF DIC
- SET DR=$PIECE(ACHSWORK,";;",5)
- SET DA=@($PIECE(ACHSWORK,";;",6))
- IF $PIECE(ACHSWORK,";;",7)
- SET DR($PIECE(ACHSWORK,";;",7))=$PIECE(ACHSWORK,";;",8)
- SET DA($PIECE(ACHSWORK,";;",7))=@($PIECE(ACHSWORK,";;",9))
- SET ACHSOT=$PIECE(ACHSWORK,";;",10)
- +4 QUIT
- +5 ;
- POSITION ;
- +1 FOR
- IF ACHSLPOS=ACHSLINE
- QUIT
- WRITE !
- SET ACHSLPOS=ACHSLPOS+1
- +2 IF ACHSCOL
- WRITE ?ACHSCOL
- +3 IF 'ACHSCOL
- WRITE ACHSCOL
- +4 QUIT
- +5 ;
- VALUE ;
- +1 IF 'DIC
- XECUTE DIC
- QUIT
- +2 IF ACHSWORK["PAYAMT"
- DO DOLLAR
- QUIT
- +3 IF ACHSWORK["PAYTXT"
- DO DOLLAR1
- QUIT
- +4 ; Naked reference in next 2 lines from line S1 and set by indirection to lines FORMAT to FORMAT+12
- +5 DO EN^DIQ1
- +6 IF $PIECE(ACHSWORK,";;",7)]""
- SET X=^($PIECE(ACHSWORK,";;",8))
- GOTO VALUE2
- +7 SET X=^($PIECE(ACHSWORK,";;",5))
- VALUE2 ;
- +1 IF ACHSOT]""
- XECUTE ACHSOT
- +2 WRITE X
- +3 QUIT
- +4 ;
- DOLLAR ;
- +1 SET X=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),U)
- SET X3=1
- +2 DO COMMA^%DTC
- +3 SET X=$EXTRACT("$$$$$$$$$$$$$",1,13-$LENGTH(X))_X
- +4 KILL X3
- +5 WRITE X
- +6 QUIT
- +7 ;
- DOLLAR1 ;
- +1 SET X=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),U)
- SET X3=1
- +2 DO COMMA^%DTC
- DO AMT^ACHSCHK1
- +3 KILL X3
- +4 WRITE X
- +5 QUIT
- +6 ;
- TEST ;
- +1 IF $DATA(IO("S"))
- XECUTE ACHSPPO
- +2 USE IO
- +3 SET ACHSLPOS=0
- +4 FOR ACHS=1:1:7
- SET ACHSWORK=$TEXT(@"FORMAT"+ACHS)
- IF ACHSWORK=""
- QUIT
- DO FMT
- DO POSITION
- WRITE "######"
- +5 FOR
- IF ACHSLPOS=ACHSCLEN
- QUIT
- WRITE !
- SET ACHSLPOS=ACHSLPOS+1
- +6 QUIT
- +7 ;
- BATCH ;EP - From option.
- +1 IF '$DATA(^ACHS(7,"CHS 638 CHECKS",DUZ(2)))
- WRITE *7,!!,"NO CHECKS BATCHED TO PRINT."
- QUIT
- +2 SET ACHSDIEN=0
- +3 FOR
- SET ACHSDIEN=$ORDER(^ACHS(7,"CHS 638 CHECKS",DUZ(2),ACHSDIEN))
- IF 'ACHSDIEN
- GOTO K
- IF $PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,12)=3&(+$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")))
- QUIT
- +4 SET ACHSPROV=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,8)
- +5 SET ACHSBAT=""
- +6 GOTO DEV
- +7 ;
- FORMAT ;42;;line #;;col #;;file # or MUMPS code;;field #;;DA;;sub-file #;;sub-file field #;;DA(sub-file #);;OUTPUT TRANSFORM
- CHECK ;;2;;45;;W "CHECK #: ",$E(1000000000+ACHSBCN,2,10)
- PONUM ;;5;;25;;9002080;;100;;DUZ(2);;9002080.01;;.01;;ACHSDIEN
- PATIENT ;;5;;42;;9002080;;100;;DUZ(2);;9002080.01;;13.64;;ACHSDIEN
- PAYTXT ;;8;;5;;9002080;;100;;DUZ(2);;9002080.01;;15;;ACHSDIEN;;S X3=1 D COMMA^%DTC,AMT^ACHSCHK1 K X3
- DATE ;;9;;54;;W $$FMTE^XLFDT(DT)
- PAYAMT ;;10;;67;;9002080;;100;;DUZ(2);;9002080.01;;15;;ACHSDIEN;;S X3=1 D COMMA^%DTC S X=$E("$$$$$$$$$$$$$",1,13-$L(X))_X K X3
- PROVIDER ;;11;;8;;9002080;;100;;DUZ(2);;9002080.01;;7;;ACHSDIEN;;S:X["," X=$P(X,",",2)_" "_$P(X,",")
- PROVSTR ;;12;;8;;9999999.11;;1301;;ACHSPROV
- PROVCTY ;;13;;8;;9999999.11;;1302;;ACHSPROV
- PROVST ;;13;; ;;9999999.11;;1303;;ACHSPROV
- PROVZIP ;;13;; ;;9999999.11;;1304;;ACHSPROV
- SVCDATE ;;27;;1;;9002080;;100;;DUZ(2);;9002080.01;;75;;ACHSDIEN
- PONUM2 ;;28;;12;;9002080;;100;;DUZ(2);;9002080.01;;.01;;ACHSDIEN
- PATIENT2 ;;28;;26;;9002080;;100;;DUZ(2);;9002080.01;;13.64;;ACHSDIEN
- PAYAMT2 ;;28;;67;;9002080;;100;;DUZ(2);;9002080.01;;15;;ACHSDIEN;;S X3=1 D COMMA^%DTC S X=$E("$$$$$$$$$$$$$",1,13-$L(X))_X K X3
- PROV2 ;;29;;12;;9002080;;100;;DUZ(2);;9002080.01;;7;;ACHSDIEN;;S:X["," X=$P(X,",",2)_" "_$P(X,",")
