Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSRP1

ACHSRP1.m

Go to the documentation of this file. 
  1. 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
  1.  ;;ITSC/SET/JVK 11-3-03 ADD VARS FOR TEST PRINT
  1.  ;;3.1*11 9.16.04 IHS/ITSC/FCJ ADDED TEST FOR E-SIG
  1.  ;;3.1*12 12.15.04 IHS/ITSC/JVK DON'T TEST SPEC. LOCAL OBLG.
  1.  ;ACHS*3.1*16 10.26.09 IHS.OIT.FCJ MOD FOR DULCE
  1.  ;
  1.  ;THIS RTN ENTERED FROM ACHSRP
  1.  ;
  1.  S DTIME=1200
  1. A1 ;
  1.  ;CHECK 'USE UNIVERSAL PO FOR 43 & 64' PARAMETER
  1.  I $$PARM^ACHS(2,16)="Y" G A2
  1.  W !!,"Please Load The ",ACHSACF," Forms In The Printer.",!!,"Press 'RETURN' When Ready: "
  1.  D READ^ACHSFU
  1.  Q:$D(DTOUT)!$D(DUOUT)
  1.  I Y?1"?".E W *7,"  ??" G A1
  1.  S DTIME=$$DTIME^XUP(DUZ)   ; RESET DTIME TO FILEMAN SETTING
  1.  ;
  1. A2 ;EP
  1.  ;
  1.  S Y=$$DIR^XBDIR("Y","Test Alignment ","YES","","","",2)
  1.  G END:$D(DTOUT)!$D(DUOUT)
  1.  S X=$T(@"FORMAT"+ACHSTYPV)
  1.  S ACHSTOPM=$P(X,";;",2)
  1.  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
  1.  ;S ACHSTAB=$P(X,";;",3)
  1.  S ACHSFML=$P(X,";;",6)
  1.  ;
  1.  I Y D TESTPRT G A2
  1.  ;
  1.  ;INITIAL PRINT OR REPRINT?
  1.  D @$S('$D(ACHSRPNT):"INITPRT",1:"REPRT")
  1.  Q
  1. TESTPRT ;EP
  1.  ;
  1.  U IO
  1.  X:$D(IO("S")) ACHSPPO
  1.  D TESTVARS             ;SET TEST VARIABLES
  1.  ;AGAIN CHECK 'USE UNIVERSAL PO FOR 43 & 64' PARAMETER
  1.  I $$PARM^ACHS(2,16)="Y" D TESTPRNT^ACHSRPU I 1
  1.  E  D TESTPRNT^ACHSRP3:'(ACHSTYPV=2),TESTPRNT^ACHSRP3D:(ACHSTYPV=2)
  1.  ;
  1.  K A,B,C,D,E,F,ACHSTPRT,ACHSSIG,ACHSDEST,ACHSTYPE,ACHSORDN,ACHSESDA,ACHSSF,T
  1.  U IO(0)
  1.  X:$D(IO("S")) ACHSPPC
  1.  Q
  1.  ;
  1.  ;TPF MY NOTE I COULD NOT FIND DUZ(2) BEING CHANGED ??????
  1.  ; NOTE:  In the B1 and C1 sub-routines, the value of DUZ(2)
  1.  ;        is changed.  The variable ACHSDUZ2 is used to ensure
  1.  ;        the correct value of DUZ(2) is kept.  This is
  1.  ;        accomplished in the 'ACTION' part of the 'Document
  1.  ;        Print' and 'Document Re-Print' menu options.
  1.  ;
  1.  Q
  1.  ;
  1.  ;LOOP FOR INITIAL PRINT
  1. INITPRT ;EP
  1.  ;
  1.  W !!,"Please Stand-By...."
  1.  U IO
  1.  ;************LOOP FOR INITIAL PRINT*************
  1.  K X
  1.  S ACHSDIEN=""
  1.  F  S ACHSDIEN=$O(^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN)) Q:+ACHSDIEN=0  D  Q:$G(Y)="X"
  1.  .S ACHSTIEN=""
  1.  .F  S ACHSTIEN=$O(^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN)) Q:+ACHSTIEN=0  D  Q:$G(Y)="X"
  1.  ..;ACHS*3.1*11 9.16.04 IHS/ITSC/FCJ ADDED NXT SECTION FOR ESIG TEST
  1.  ..I $D(ACHSEFL) D  I ACHSEFLG S $P(ACHSEFL,U,3)=$P(ACHSEFL,U,3)+1 Q
  1.  ...S ACHSEFLG=0
  1.  ...;ITSC/SET/JVK ACHS*3.1*12 ADD LINE BELOW TO OMIT SPEC. LOCAL OBLG.
  1.  ...Q:$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)=2
  1.  ...Q:$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,12)>1
  1.  ...;ITSC/SET/JVK ACHS*3.1*12 ADD LINE ABOVE IF NOT OPEN OR SUPPLEMENT
  1.  ...Q:$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,2)<$P(ACHSEFL,U,2)
  1.  ...I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,28)'?1N.N S ACHSEFLG=1 Q
  1.  ...I $P(ACHSEFL,U)=1,$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,30)'?1N.N S ACHSEFLG=1
  1.  ..;ACHS*3.1*11 9.16.04 IHS/ITSC/FCJ END OF CHANGES
  1.  ..U IO
  1.  ..X:$D(IO("S")) ACHSPPO     ;SLAVE PRINTER OPEN
  1.  ..;D INIT^ACHSRP2           ;DONE IN ACHSRP2
  1.  ..;D SB1                     ;GET FACILITY INFO AND FINANCE CODE
  1.  ..D ^ACHSRP2                ;
  1.  ..U IO(0)
  1.  ..X:$D(IO("S")) ACHSPPC      ;SLAVE PRINTER CLOSED
  1.  ..R *X:2
  1.  ..I X=27 D PTRSTOP  ;IF USER HITS ESCAPE, CONFIRM STOP PRINTING
  1.  ..;
  1.  D END
  1.  Q
  1.  ;
  1.  ;CLOSE OUT
  1. END ;EP
  1.  U IO(0)
  1.  X:$D(IO("S")) ACHSPPC   ;SLAVE PRINTER CLOSED
  1.  W "   Done.",!!
  1.  ;
  1.  K ACHSFML             ;??
  1.  S DTIME=$$DTIME^XUP(DUZ) ;RESET DTIME TO NORMAL SETTING
  1.  Q
  1.  ;
  1. SB1 ;EP
  1.  ;GET FACILITY INFO
  1.  K B
  1.  D FAC^ACHSUDF   ; GET MAILING ADDRESS AND PLACE IN B ARRAY
  1.  D FC^ACHSUF     ; GET FINANCE CODE
  1.  Q
  1.  ;
  1.  ;LOOP FOR REPRINT
  1. REPRT ;EP
  1.  S ACHSDIEN=""
  1.  F  S ACHSDIEN=$O(^TMP("ACHSRR",$J,DUZ(2),ACHSTYPV,ACHSDIEN)) Q:ACHSDIEN=""  D  Q:$G(Y)="X"
  1.  .S ACHSTIEN=""
  1.  .F  S ACHSTIEN=$O(^TMP("ACHSRR",$J,DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN)) Q:ACHSTIEN=""  D  Q:$G(Y)="X"
  1.  ..U IO
  1.  ..X:$D(IO("S")) ACHSPPO
  1.  ..D SB1,^ACHSRP2
  1.  ..U IO(0)
  1.  ..X:$D(IO("S")) ACHSPPC
  1.  ..R *X:2
  1.  ..I X=27 D PTRSTOP
  1.  D END
  1.  Q
  1.  ;
  1. FORMAT ;;SKIP LINES;;L MARGIN;;TEST WIDTH;;TEST LENGTH;;FORM LENGTH
  1. 43 ;;2;;3;;40;;9;;66
  1. 57 ;;6;;3;;36;;7;;66
  1. 64 ;;2;;3;;40;;10;;66
  1.  ;
  1.  Q
  1.  ;
  1.  ;CONFIRM USER WANTS TO END PRINTING
  1. PTRSTOP ;EP
  1.  U IO(0)
  1.  X:$D(IO("S")) ACHSPPC
  1.  W *7,*7,*7
  1.  F  R X:0 Q:'$T
  1.  U IO(0)
  1.  X:$D(IO("S")) ACHSPPC
  1.  W !!,"Enter <RETURN> to Continue <X & RETURN> to Cancel  "
  1.  D READ^ACHSFU
  1.  Q
  1.  ;
  1.  ;
  1.  ;SET UP TEST VARIABLES FOR TEST ALIGNMENT
  1. TESTVARS ;EP
  1.  ;ITSC/SET/JVK 10/21/2004
  1.  S:'$D(ACHSMPP) ACHSMPP=""
  1.  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"
  1.  S A(10)="Desc: xxxxxxxxxxxxx",A(11)="999999999"
  1.  S B(1)="ORDERING OFFICE",(B(2),D(1),D(2))="STREET ADDRESS",(B(3),D(3))="CITY, ST  ZIP",B(4)="999999"
  1.  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
  1.  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
  1.  ;
  1.  ;ITSC/SET/JVK 12/21/04 ACHS*3.1*12
  1.  S ACHSACFY=9999,ACHSDHHS="HHSI999X9999999"
  1.  S ACHSDCR=999,ACHSORDN="9-X99-99999",ACHSDEST="F",ACHSSIG="ORDERING OFFICIAL",ACHSTYPE="",ACHSSF="99",ACHSESDA=9,T=0
  1.  S ACHSTPRT=""
  1.  ;ITSC/SET/JVK 11/3/03 SETUP TEST VARS FOR E-SIG
  1.  S ACHSESIG="SIGNATURE,OFFICIAL",ACHSEDTE="XX/XX/XXXX"
  1.  S ACHSASIG="SIGNATURE,OFFICIAL",ACHSADTE="XX/XX/XXXX"
  1.  Q
  1.  ;