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,",")
