ACHSRP1 ; IHS/ITSC/PMF - PRINT CHS FORMS - LOAD FORMS, TEST, PRINT ; [ 01/31/2005 9:45 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,11,12,16**;JUN 11, 2001
;;ITSC/SET/JVK 11-3-03 ADD VARS FOR TEST PRINT
;;3.1*11 9.16.04 IHS/ITSC/FCJ ADDED TEST FOR E-SIG
;;3.1*12 12.15.04 IHS/ITSC/JVK DON'T TEST SPEC. LOCAL OBLG.
;ACHS*3.1*16 10.26.09 IHS.OIT.FCJ MOD FOR DULCE
;
;THIS RTN ENTERED FROM ACHSRP
;
S DTIME=1200
A1 ;
;CHECK 'USE UNIVERSAL PO FOR 43 & 64' PARAMETER
I $$PARM^ACHS(2,16)="Y" G A2
W !!,"Please Load The ",ACHSACF," Forms In The Printer.",!!,"Press 'RETURN' When Ready: "
D READ^ACHSFU
Q:$D(DTOUT)!$D(DUOUT)
I Y?1"?".E W *7," ??" G A1
S DTIME=$$DTIME^XUP(DUZ) ; RESET DTIME TO FILEMAN SETTING
;
A2 ;EP
;
S Y=$$DIR^XBDIR("Y","Test Alignment ","YES","","","",2)
G END:$D(DTOUT)!$D(DUOUT)
S X=$T(@"FORMAT"+ACHSTYPV)
S ACHSTOPM=$P(X,";;",2)
S ACHSTAB=$S($P(^AUTTLOC(DUZ(2),0),U,10)=202810:5,1:$P(X,";;",3)) ;ACHS*3.1*16 10.26.2009 IHS.OIT.FCJ ADDED FMT TST FOR DULCE
;S ACHSTAB=$P(X,";;",3)
S ACHSFML=$P(X,";;",6)
;
I Y D TESTPRT G A2
;
;INITIAL PRINT OR REPRINT?
D @$S('$D(ACHSRPNT):"INITPRT",1:"REPRT")
Q
TESTPRT ;EP
;
U IO
X:$D(IO("S")) ACHSPPO
D TESTVARS ;SET TEST VARIABLES
;AGAIN CHECK 'USE UNIVERSAL PO FOR 43 & 64' PARAMETER
I $$PARM^ACHS(2,16)="Y" D TESTPRNT^ACHSRPU I 1
E D TESTPRNT^ACHSRP3:'(ACHSTYPV=2),TESTPRNT^ACHSRP3D:(ACHSTYPV=2)
;
K A,B,C,D,E,F,ACHSTPRT,ACHSSIG,ACHSDEST,ACHSTYPE,ACHSORDN,ACHSESDA,ACHSSF,T
U IO(0)
X:$D(IO("S")) ACHSPPC
Q
;
;TPF MY NOTE I COULD NOT FIND DUZ(2) BEING CHANGED ??????
; NOTE: In the B1 and C1 sub-routines, the value of DUZ(2)
; is changed. The variable ACHSDUZ2 is used to ensure
; the correct value of DUZ(2) is kept. This is
; accomplished in the 'ACTION' part of the 'Document
; Print' and 'Document Re-Print' menu options.
;
Q
;
;LOOP FOR INITIAL PRINT
INITPRT ;EP
;
W !!,"Please Stand-By...."
U IO
;************LOOP FOR INITIAL PRINT*************
K X
S ACHSDIEN=""
F S ACHSDIEN=$O(^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN)) Q:+ACHSDIEN=0 D Q:$G(Y)="X"
.S ACHSTIEN=""
.F S ACHSTIEN=$O(^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN)) Q:+ACHSTIEN=0 D Q:$G(Y)="X"
..;ACHS*3.1*11 9.16.04 IHS/ITSC/FCJ ADDED NXT SECTION FOR ESIG TEST
..I $D(ACHSEFL) D I ACHSEFLG S $P(ACHSEFL,U,3)=$P(ACHSEFL,U,3)+1 Q
...S ACHSEFLG=0
...;ITSC/SET/JVK ACHS*3.1*12 ADD LINE BELOW TO OMIT SPEC. LOCAL OBLG.
...Q:$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)=2
...Q:$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,12)>1
...;ITSC/SET/JVK ACHS*3.1*12 ADD LINE ABOVE IF NOT OPEN OR SUPPLEMENT
...Q:$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,2)<$P(ACHSEFL,U,2)
...I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,28)'?1N.N S ACHSEFLG=1 Q
...I $P(ACHSEFL,U)=1,$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,30)'?1N.N S ACHSEFLG=1
..;ACHS*3.1*11 9.16.04 IHS/ITSC/FCJ END OF CHANGES
..U IO
..X:$D(IO("S")) ACHSPPO ;SLAVE PRINTER OPEN
..;D INIT^ACHSRP2 ;DONE IN ACHSRP2
..;D SB1 ;GET FACILITY INFO AND FINANCE CODE
..D ^ACHSRP2 ;
..U IO(0)
..X:$D(IO("S")) ACHSPPC ;SLAVE PRINTER CLOSED
..R *X:2
..I X=27 D PTRSTOP ;IF USER HITS ESCAPE, CONFIRM STOP PRINTING
..;
D END
Q
;
;CLOSE OUT
END ;EP
U IO(0)
X:$D(IO("S")) ACHSPPC ;SLAVE PRINTER CLOSED
W " Done.",!!
;
K ACHSFML ;??
S DTIME=$$DTIME^XUP(DUZ) ;RESET DTIME TO NORMAL SETTING
Q
;
SB1 ;EP
;GET FACILITY INFO
K B
D FAC^ACHSUDF ; GET MAILING ADDRESS AND PLACE IN B ARRAY
D FC^ACHSUF ; GET FINANCE CODE
Q
;
;LOOP FOR REPRINT
REPRT ;EP
S ACHSDIEN=""
F S ACHSDIEN=$O(^TMP("ACHSRR",$J,DUZ(2),ACHSTYPV,ACHSDIEN)) Q:ACHSDIEN="" D Q:$G(Y)="X"
.S ACHSTIEN=""
.F S ACHSTIEN=$O(^TMP("ACHSRR",$J,DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN)) Q:ACHSTIEN="" D Q:$G(Y)="X"
..U IO
..X:$D(IO("S")) ACHSPPO
..D SB1,^ACHSRP2
..U IO(0)
..X:$D(IO("S")) ACHSPPC
..R *X:2
..I X=27 D PTRSTOP
D END
Q
;
FORMAT ;;SKIP LINES;;L MARGIN;;TEST WIDTH;;TEST LENGTH;;FORM LENGTH
43 ;;2;;3;;40;;9;;66
57 ;;6;;3;;36;;7;;66
64 ;;2;;3;;40;;10;;66
;
Q
;
;CONFIRM USER WANTS TO END PRINTING
PTRSTOP ;EP
U IO(0)
X:$D(IO("S")) ACHSPPC
W *7,*7,*7
F R X:0 Q:'$T
U IO(0)
X:$D(IO("S")) ACHSPPC
W !!,"Enter <RETURN> to Continue <X & RETURN> to Cancel "
D READ^ACHSFU
Q
;
;
;SET UP TEST VARIABLES FOR TEST ALIGNMENT
TESTVARS ;EP
;ITSC/SET/JVK 10/21/2004
S:'$D(ACHSMPP) ACHSMPP=""
S A(1)="Fac: 999999 IHS#: 999999 SSN999SSN",A(2)="PATIENT,NAME",A(3)="PATIENT ADRS 1",A(4)="99-99-99 X 999",A(5)="999-99-99",A(6)="Est. date-of-svc.: XXX 99, 99",A(7)="Description of srvcs"
S A(10)="Desc: xxxxxxxxxxxxx",A(11)="999999999"
S B(1)="ORDERING OFFICE",(B(2),D(1),D(2))="STREET ADDRESS",(B(3),D(3))="CITY, ST ZIP",B(4)="999999"
S C(4)="XXX 99, 99 XXX 99, 99",D(1)="PROVIDER",D(4)="9999999999-A1",D(5)="XX",D(6)="CDE PFX-NUMB",D(7)="VT",D(14)=3
S E(7)="99-99-99",E(8)="OPTNL",E(9)="$000.00",F(6)="99999-ZZ",F(7)="J123456",F(9)="99.9Z",D(10)=13
;
;ITSC/SET/JVK 12/21/04 ACHS*3.1*12
S ACHSACFY=9999,ACHSDHHS="HHSI999X9999999"
S ACHSDCR=999,ACHSORDN="9-X99-99999",ACHSDEST="F",ACHSSIG="ORDERING OFFICIAL",ACHSTYPE="",ACHSSF="99",ACHSESDA=9,T=0
S ACHSTPRT=""
;ITSC/SET/JVK 11/3/03 SETUP TEST VARS FOR E-SIG
S ACHSESIG="SIGNATURE,OFFICIAL",ACHSEDTE="XX/XX/XXXX"
S ACHSASIG="SIGNATURE,OFFICIAL",ACHSADTE="XX/XX/XXXX"
Q
;
ACHSRP1 ; IHS/ITSC/PMF - PRINT CHS FORMS - LOAD FORMS, TEST, PRINT ; [ 01/31/2005 9:45 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,11,12,16**;JUN 11, 2001
+2 ;;ITSC/SET/JVK 11-3-03 ADD VARS FOR TEST PRINT
+3 ;;3.1*11 9.16.04 IHS/ITSC/FCJ ADDED TEST FOR E-SIG
+4 ;;3.1*12 12.15.04 IHS/ITSC/JVK DON'T TEST SPEC. LOCAL OBLG.
+5 ;ACHS*3.1*16 10.26.09 IHS.OIT.FCJ MOD FOR DULCE
+6 ;
+7 ;THIS RTN ENTERED FROM ACHSRP
+8 ;
+9 SET DTIME=1200
A1 ;
+1 ;CHECK 'USE UNIVERSAL PO FOR 43 & 64' PARAMETER
+2 IF $$PARM^ACHS(2,16)="Y"
GOTO A2
+3 WRITE !!,"Please Load The ",ACHSACF," Forms In The Printer.",!!,"Press 'RETURN' When Ready: "
+4 DO READ^ACHSFU
+5 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+6 IF Y?1"?".E
WRITE *7," ??"
GOTO A1
+7 ; RESET DTIME TO FILEMAN SETTING
SET DTIME=$$DTIME^XUP(DUZ)
+8 ;
A2 ;EP
+1 ;
+2 SET Y=$$DIR^XBDIR("Y","Test Alignment ","YES","","","",2)
+3 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO END
+4 SET X=$TEXT(@"FORMAT"+ACHSTYPV)
+5 SET ACHSTOPM=$PIECE(X,";;",2)
+6 ;ACHS*3.1*16 10.26.2009 IHS.OIT.FCJ ADDED FMT TST FOR DULCE
SET ACHSTAB=$SELECT($PIECE(^AUTTLOC(DUZ(2),0),U,10)=202810:5,1:$PIECE(X,";;",3))
+7 ;S ACHSTAB=$P(X,";;",3)
+8 SET ACHSFML=$PIECE(X,";;",6)
+9 ;
+10 IF Y
DO TESTPRT
GOTO A2
+11 ;
+12 ;INITIAL PRINT OR REPRINT?
+13 DO @$SELECT('$DATA(ACHSRPNT):"INITPRT",1:"REPRT")
+14 QUIT
TESTPRT ;EP
+1 ;
+2 USE IO
+3 IF $DATA(IO("S"))
XECUTE ACHSPPO
+4 ;SET TEST VARIABLES
DO TESTVARS
+5 ;AGAIN CHECK 'USE UNIVERSAL PO FOR 43 & 64' PARAMETER
+6 IF $$PARM^ACHS(2,16)="Y"
DO TESTPRNT^ACHSRPU
IF 1
+7 IF '$TEST
IF '(ACHSTYPV=2)
DO TESTPRNT^ACHSRP3
IF (ACHSTYPV=2)
DO TESTPRNT^ACHSRP3D
+8 ;
+9 KILL A,B,C,D,E,F,ACHSTPRT,ACHSSIG,ACHSDEST,ACHSTYPE,ACHSORDN,ACHSESDA,ACHSSF,T
+10 USE IO(0)
+11 IF $DATA(IO("S"))
XECUTE ACHSPPC
+12 QUIT
+13 ;
+14 ;TPF MY NOTE I COULD NOT FIND DUZ(2) BEING CHANGED ??????
+15 ; NOTE: In the B1 and C1 sub-routines, the value of DUZ(2)
+16 ; is changed. The variable ACHSDUZ2 is used to ensure
+17 ; the correct value of DUZ(2) is kept. This is
+18 ; accomplished in the 'ACTION' part of the 'Document
+19 ; Print' and 'Document Re-Print' menu options.
+20 ;
+21 QUIT
+22 ;
+23 ;LOOP FOR INITIAL PRINT
INITPRT ;EP
+1 ;
+2 WRITE !!,"Please Stand-By...."
+3 USE IO
+4 ;************LOOP FOR INITIAL PRINT*************
+5 KILL X
+6 SET ACHSDIEN=""
+7 FOR
SET ACHSDIEN=$ORDER(^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN))
IF +ACHSDIEN=0
QUIT
Begin DoDot:1
+8 SET ACHSTIEN=""
+9 FOR
SET ACHSTIEN=$ORDER(^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN))
IF +ACHSTIEN=0
QUIT
Begin DoDot:2
+10 ;ACHS*3.1*11 9.16.04 IHS/ITSC/FCJ ADDED NXT SECTION FOR ESIG TEST
+11 IF $DATA(ACHSEFL)
Begin DoDot:3
+12 SET ACHSEFLG=0
+13 ;ITSC/SET/JVK ACHS*3.1*12 ADD LINE BELOW TO OMIT SPEC. LOCAL OBLG.
+14 IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)=2
QUIT
+15 IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,12)>1
QUIT
+16 ;ITSC/SET/JVK ACHS*3.1*12 ADD LINE ABOVE IF NOT OPEN OR SUPPLEMENT
+17 IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,2)<$PIECE(ACHSEFL,U,2)
QUIT
+18 IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,28)'?1N.N
SET ACHSEFLG=1
QUIT
+19 IF $PIECE(ACHSEFL,U)=1
IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,30)'?1N.N
SET ACHSEFLG=1
End DoDot:3
IF ACHSEFLG
SET $PIECE(ACHSEFL,U,3)=$PIECE(ACHSEFL,U,3)+1
QUIT
+20 ;ACHS*3.1*11 9.16.04 IHS/ITSC/FCJ END OF CHANGES
+21 USE IO
+22 ;SLAVE PRINTER OPEN
IF $DATA(IO("S"))
XECUTE ACHSPPO
+23 ;D INIT^ACHSRP2 ;DONE IN ACHSRP2
+24 ;D SB1 ;GET FACILITY INFO AND FINANCE CODE
+25 ;
DO ^ACHSRP2
+26 USE IO(0)
+27 ;SLAVE PRINTER CLOSED
IF $DATA(IO("S"))
XECUTE ACHSPPC
+28 READ *X:2
+29 ;IF USER HITS ESCAPE, CONFIRM STOP PRINTING
IF X=27
DO PTRSTOP
+30 ;
End DoDot:2
IF $GET(Y)="X"
QUIT
End DoDot:1
IF $GET(Y)="X"
QUIT
+31 DO END
+32 QUIT
+33 ;
+34 ;CLOSE OUT
END ;EP
+1 USE IO(0)
+2 ;SLAVE PRINTER CLOSED
IF $DATA(IO("S"))
XECUTE ACHSPPC
+3 WRITE " Done.",!!
+4 ;
+5 ;??
KILL ACHSFML
+6 ;RESET DTIME TO NORMAL SETTING
SET DTIME=$$DTIME^XUP(DUZ)
+7 QUIT
+8 ;
SB1 ;EP
+1 ;GET FACILITY INFO
+2 KILL B
+3 ; GET MAILING ADDRESS AND PLACE IN B ARRAY
DO FAC^ACHSUDF
+4 ; GET FINANCE CODE
DO FC^ACHSUF
+5 QUIT
+6 ;
+7 ;LOOP FOR REPRINT
REPRT ;EP
+1 SET ACHSDIEN=""
+2 FOR
SET ACHSDIEN=$ORDER(^TMP("ACHSRR",$JOB,DUZ(2),ACHSTYPV,ACHSDIEN))
IF ACHSDIEN=""
QUIT
Begin DoDot:1
+3 SET ACHSTIEN=""
+4 FOR
SET ACHSTIEN=$ORDER(^TMP("ACHSRR",$JOB,DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN))
IF ACHSTIEN=""
QUIT
Begin DoDot:2
+5 USE IO
+6 IF $DATA(IO("S"))
XECUTE ACHSPPO
+7 DO SB1
DO ^ACHSRP2
+8 USE IO(0)
+9 IF $DATA(IO("S"))
XECUTE ACHSPPC
+10 READ *X:2
+11 IF X=27
DO PTRSTOP
End DoDot:2
IF $GET(Y)="X"
QUIT
End DoDot:1
IF $GET(Y)="X"
QUIT
+12 DO END
+13 QUIT
+14 ;
FORMAT ;;SKIP LINES;;L MARGIN;;TEST WIDTH;;TEST LENGTH;;FORM LENGTH
43 ;;2;;3;;40;;9;;66
57 ;;6;;3;;36;;7;;66
64 ;;2;;3;;40;;10;;66
+1 ;
+2 QUIT
+3 ;
+4 ;CONFIRM USER WANTS TO END PRINTING
PTRSTOP ;EP
+1 USE IO(0)
+2 IF $DATA(IO("S"))
XECUTE ACHSPPC
+3 WRITE *7,*7,*7
+4 FOR
READ X:0
IF '$TEST
QUIT
+5 USE IO(0)
+6 IF $DATA(IO("S"))
XECUTE ACHSPPC
+7 WRITE !!,"Enter <RETURN> to Continue <X & RETURN> to Cancel "
+8 DO READ^ACHSFU
+9 QUIT
+10 ;
+11 ;
+12 ;SET UP TEST VARIABLES FOR TEST ALIGNMENT
TESTVARS ;EP
+1 ;ITSC/SET/JVK 10/21/2004
+2 IF '$DATA(ACHSMPP)
SET ACHSMPP=""
+3 SET A(1)="Fac: 999999 IHS#: 999999 SSN999SSN"
SET A(2)="PATIENT,NAME"
SET A(3)="PATIENT ADRS 1"
SET A(4)="99-99-99 X 999"
SET A(5)="999-99-99"
SET A(6)="Est. date-of-svc.: XXX 99, 99"
SET A(7)="Description of srvcs"
+4 SET A(10)="Desc: xxxxxxxxxxxxx"
SET A(11)="999999999"
+5 SET B(1)="ORDERING OFFICE"
SET (B(2),D(1),D(2))="STREET ADDRESS"
SET (B(3),D(3))="CITY, ST ZIP"
SET B(4)="999999"
+6 SET C(4)="XXX 99, 99 XXX 99, 99"
SET D(1)="PROVIDER"
SET D(4)="9999999999-A1"
SET D(5)="XX"
SET D(6)="CDE PFX-NUMB"
SET D(7)="VT"
SET D(14)=3
+7 SET E(7)="99-99-99"
SET E(8)="OPTNL"
SET E(9)="$000.00"
SET F(6)="99999-ZZ"
SET F(7)="J123456"
SET F(9)="99.9Z"
SET D(10)=13
+8 ;
+9 ;ITSC/SET/JVK 12/21/04 ACHS*3.1*12
+10 SET ACHSACFY=9999
SET ACHSDHHS="HHSI999X9999999"
+11 SET ACHSDCR=999
SET ACHSORDN="9-X99-99999"
SET ACHSDEST="F"
SET ACHSSIG="ORDERING OFFICIAL"
SET ACHSTYPE=""
SET ACHSSF="99"
SET ACHSESDA=9
SET T=0
+12 SET ACHSTPRT=""
+13 ;ITSC/SET/JVK 11/3/03 SETUP TEST VARS FOR E-SIG
+14 SET ACHSESIG="SIGNATURE,OFFICIAL"
SET ACHSEDTE="XX/XX/XXXX"
+15 SET ACHSASIG="SIGNATURE,OFFICIAL"
SET ACHSADTE="XX/XX/XXXX"
+16 QUIT
+17 ;
