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

AFSHEX1.m

Go to the documentation of this file. 
  1. AFSHEX1 ;IHS/OIRM/DSD/JDM-DHR SPLITOUT PROGRAM #2;    [ 10/27/2004   4:20 PM ]
  1.  ;;3.0T1;AO FINANCIAL DATA MGMT SYSTEM;**2,16,13**;FEB 02, 1999
  1.  ;;MODIFICATIONS ARE MADE FOR CACHE' COMPLIANCE; ACR*2.1*9
  1. A0 D ^XBCLS K AFSJFLG
  1.  F I=1:1:70 W "*"
  1.  W !,?10,"D H R   S P L I T - O U T   I N   P R O C E S S",!
  1.  F I=1:1:70 W "*"
  1.  W !
  1.  S AFSHPHDR(1)="LISTING OF INDIVIDUAL RECORDS",AFSHPHDR(2)="DHR BATCH RECONCILIATION TABLE",AFSHPGNO=0,AFSHBTCT=0,AFSHPLCT=0,AFSHRPT=1,AFSHTRCT=0 K AFSHBTNM
  1. A0B ;D PTRDEF^AFSTUT4 Q:$D(AFSJFLG)
  1.  ;D PTRSEL^AFSTUT4 Q:$D(AFSJFLG)
  1.  S %ZIS("A")="What PRINTER do you want to use? "
  1.  D ^%ZIS
  1.  G Q:POP
  1.  U IO(0) W !
  1.  ;I IO>0 S AFSHPTRD=IO                       ;ACR*2.1*13.01 IM13574
  1.  Q:IO']""  S AFSHPTRD=IO                     ;ACR*2.1*13.01 IM13574
  1.  D PTRHDR^AFSHEX2
  1. A0C S X=$P(^AUTTLOC(DUZ(2),0),U,4),AFSHCNPF=$P(^AUTTAREA(X,0),U,4),AFSHAREA=$P(^(0),U,1),AFSHAPN=$P(^AUTTSITE(1,0),U,2)
  1.  I $E(AFSHCNPF,1,1)'="J"!($L(AFSHAREA)<3)!(+AFSHAPN'>0) S AFSERMSG="ACCOUNTING INFORMATION MISSING" G JCANCEL^AFSHEX1A
  1.  S AFSHDEST=AFSCCTR
  1.  D NOW^%DTC S AFSHNOW=% S $P(^AFSHRCDS(AFSHBCLR,0),U,2)=AFSHNOW
  1.  ;K ^AFSHTEMP ; SCRATCH GLOBAL FOR TX DATA TO EXT FILE killed ;ACR*2.1*13.02 IM13574
  1.  N AFSKIL S AFSKIL="^AFSHTEMP"                 ; ACR*2.1*13.02 IM13574
  1.  K @AFSKIL  ; SCRATCH GLOBAL FOR TX DATA TO EXT FILE killed  ;ACR*2.1*13.02 IM13574
  1.  K ^TMP("ACR",$J,"EXP")
  1. B0 S AFSR=AFSHBCLR,(AFSRR,AFSRRR,AFSRRRR)=0
  1. B1 S AFSRR=$O(^AFSHRCDS(AFSR,"D","B",AFSRR)) G ZEND:+AFSRR=0
  1. B2 S AFSRRR=$O(^AFSHRCDS(AFSR,"D",AFSRR,"I","B",AFSRRR)) G B1:AFSRRR=""
  1.  S AFSRRRP=0,AFSRRRP=$O(^AFSHRCDS(AFSR,"D",AFSRR,"I","B",AFSRRR,AFSRRRP))
  1.  S AFSRRA=$P(^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,0),U,1),AFSHBCNT=$P(^(0),U,5),AFSHBTOT=$P(^(0),U,6),AFSHBAP=$P(^(0),U,2)
  1.  S AFSHBDAT=AFSRR D PCCHDR^AFSHEX1A
  1.  S AFSRRRR=0
  1. B3 S AFSRRRR=$O(^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,"S",AFSRRRR)) G BTRL:+AFSRRRR=0
  1.  S AFSHYY=^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,"S",AFSRRRR,0)
  1.  I AFSRRRR#100=0 U IO(0) W $J(AFSRRRR,8)
  1.  D ^AFSHEX2
  1.  S AFSHTRCT=AFSHTRCT+2,AFSHPLCT=AFSHPLCT+2
  1.  S ACRFMS=$G(^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,"S",AFSRRRR,99))
  1.  I $G(ACRFMS) S ^TMP("ACR",$J,"EXP",ACRFMS)=AFSR_U_AFSRR_U_AFSRRR_U_AFSRRRR
  1.  G B3
  1. BTRL D PCCTRL^AFSHEX1A
  1.  G B2
  1. ZEND ;EXIT POINT FROM $O -- DO NOT DELETE
  1.  I AFSHPLCT>55 D PTRHDR^AFSHEX2
  1.  S AFSJCLNO=8 S:AFSCCTR="BCS" AFSJCLNO=10
  1.  U AFSHPTRD W !!,?10,"NUMBER OF OUTPUT DHR RECORDS = ",?45,$J(AFSHTRCT,8),!!,?10,"NUMBER OF JCL RECORDS = ",?45,$J(AFSJCLNO,8),!!
  1.  S X="",$P(X,"-",44)="" W ?10,X,!,?15,"TOTAL RECORDS TO TRANSMIT = ",?45,$J(AFSHTRCT+AFSJCLNO,8),!!
  1. REPORT2 ;
  1.  S AFSHRPT=2,AFSHTOT1=0,AFSHTOT2=0
  1.  D PTRHDR^AFSHEX2
  1. REP0 S AFSR=0,AFSSPACE="",$P(AFSSPACE," ",41)=""
  1. REP1 S AFSR=$O(AFSHBTNM(AFSR)) G REPEND:AFSR=""
  1.  S X=AFSHBTNM(AFSR),Y=$P(X,U,1)
  1.  S AFSHPTRL=$E(AFSSPACE,1,35)_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "_$P(X,U,2)_$E(AFSSPACE,1,20)_$J($P(X,U,3),4)
  1.  S AFSHPLCT=AFSHPLCT+2
  1.  S AFSHTOT1=AFSHTOT1+1,AFSHTOT2=AFSHTOT2+$P(X,U,3)
  1.  D PTRWRITE^AFSHEX2 S AFSHPTRL="" D PTRWRITE^AFSHEX2
  1.  G REP1
  1. REPEND S AFSHPTRL="" D PTRWRITE^AFSHEX2
  1.  S AFSHPTRL=$E(AFSSPACE,1,30)_"TOTAL   "_$J(AFSHTOT1,4)_$E(AFSSPACE,1,20)_$J(AFSHTOT2,7) D PTRWRITE^AFSHEX2
  1.  ;I $D(AFSHPTRD)&('$D(^AFSHPARM(DUZ(2),0))!($P(^AFSHPARM(DUZ(2),0),U,5)["N")) S IO=AFSHPTRD D ^%ZISC ;LINE CHGED FOR 1166 POSTING ;ACR*2.1*13.02 IM13574
  1.  I $D(AFSHPTRD),('$D(^AFSHPARM(DUZ(2),0))!($P(^AFSHPARM(DUZ(2),0),U,5)["N")) D ^%ZISC  ;ACR*2.1*13.02 IM13574
  1.  ;I $D(%DEV) S IO=%DEV D ^%ZISC                   ;ACR*2.1*13.02 IM13574
  1.  I $D(%DEV) D CLOSE^%ZISH()                       ;ACR*2.1*13.02 IM13574
  1.  ;L                                               ;ACR*2.1*13.02 IM13574
  1. FILECPY ;;COPY ^AFSHTEMP GLOBAL  TO PCC & BCS UNIX FILES
  1.  S (AFSFLNM1,AFSFLNM2)="",AFSRCNT=0
  1.  I AFSHDTNM="DHRP"!(AFSHDTNM="dhp") G FCOPYA
  1.  S AFSHDTNM="dhc",AFSCCTR="PCC",AFSPKGNM="ACHS"
  1. FCOPYA ;
  1.  I $D(AFSHDTNM) S AFSZSAV=AFSHDTNM ;AFSH*3.0T1*2
  1.  D FILESEL^AFSEXUT0 I $D(AFSJFLG) G ENDERR^AFSHEX0A
  1.  I $D(AFSZSAV) S AFSHDTNM=AFSZSAV ;AFSH*3.0T1*2
  1.  K AFSZSAV ;AFSH*3.0T1*2
  1.  S AFSFLNM1=AFSEXFN
  1.  S %FN=AFSEXFN,%IN=0 D OPENHFS^AFSTCK1 I %ZA<0 D ERROR^AFSTCK1 S AFSERMSG="JOB PROCESSING ERROR" G JCANCEL^AFSHEX1A
  1.  D PCCJHDR^AFSHEX1A
  1.  U IO(0) W !!,?10,"COPYING DHR DATA TO ",AFSEXFN,!!
  1.  D COPY2
  1.  D PCCJTRL^AFSHEX1A
  1.  ;S IO=%DEV D ^%ZISC                             ;ACR*2.1*13.02 IM13574
  1.  D CLOSE^%ZISH()                                 ;ACR*2.1*13.02 IM13574
  1.  S AFSJCLCT(1)=AFSRCNT+AFSZCNT
  1.  D LINK(AFSEXFN)
  1.  I AFSHDTNM="DHRP"!(AFSHDTNM="dhp") G LOG1
  1.  S AFSHDTNM="bhc",AFSCCTR="BCS",AFSPKGNM="ACHS"
  1.  D FILESEL^AFSEXUT0 I $D(AFSJFLG) G ENDERR^AFSHEX0A
  1.  K %DEV S AFSRCNT=0
  1.  S AFSFLNM2=AFSEXFN
  1.  S %FN=AFSEXFN,%IN=0 D OPENHFS^AFSTCK1 I %ZA<0 D ERROR^AFSTCK1 S AFSERMSG="JOB PROCESSING ERROR" G JCANCEL^AFSHEX1A
  1.  D FIJHDR^AFSHEX1A
  1.  U IO(0) W !!,?10,"COPYING DHR DATA TO ",AFSEXFN,!!
  1.  D COPY2
  1.  D FIJTRL^AFSHEX1A
  1.  ;S IO=%DEV D ^%ZISC                             ;ACR*2.1*13.02 IM13574
  1.  D CLOSE^%ZISH()                                 ;ACR*2.1*13.02 IM13574
  1.  S AFSJCLCT(2)=AFSRCNT+AFSZCNT
  1.  D LINK(AFSEXFN)
  1. LOG1 S AFSEXFNS=$P(AFSFLNM1,"/",5) D TXLOGADD^AFSTXUT0
  1.  I +AFSY<0 U IO(0) W "IHS TX LOG POSTING ERROR" G JCANCEL^AFSHEX1A
  1.  S AFSRCNT=AFSJCLCT(1)
  1.  I +AFSY D NORMEND^AFSTUT5
  1.  I AFSFLNM2="" G BKUP
  1.  S AFSEXFNS=$P(AFSFLNM2,"/",5) D TXLOGADD^AFSTXUT0
  1.  I +AFSY<0 U IO(0) W "IHS TX LOG POSTING ERROR" G JCANCEL^AFSHEX1A
  1.  S AFSRCNT=AFSJCLCT(2)
  1.  I +AFSY D NORMEND^AFSTUT5
  1.  ;  DO BACKUP HERE
  1. BKUP K AFSJFLG S AFSRTCD=999
  1.  I '$D(AFSHPARM(DUZ(2))) G BKUPA
  1.  I $P(^AFSHPARM(DUZ(2)),U,4)="N" G BKUPOK
  1. BKUPA S %SDIR="",%FN=AFSFLNM1_" "_AFSFLNM2,AFSDTYPE="C",AFSEXFN="DHR TX FILES" D TARBKUP^AFSARCH0
  1.  I AFSRTCD=0 G BKUPOK
  1.  K DIR S DIR("A")="Do you want to try BACKUP file to "_AFSDNAME_" AGAIN?",DIR("B")="Y",DIR(0)="Y" D ^DIR
  1.  I Y=0 S AFSJFLG=1 Q
  1.  W !!,*7,"Make sure an appropriate TAPE (Write Enabled) is in the ",AFSDNAME," DRIVE",!
  1.  K DIR S DIR(0)="E" D ^DIR
  1.  I Y=0 S AFSJFLG=1 G ENDERR^AFSHEX0A
  1.  G BKUP
  1. BKUPOK Q
  1. COPY2 ;;SUBROUTINE TO COPY TX DATA FROM GLOBAL TO EXT FILE
  1.  S AFSGCNT=0,AFSZCNT=0
  1. COPY2A S AFSGCNT=$O(^AFSHTEMP(AFSGCNT)) G COPY2END:AFSGCNT=""
  1.  S AFSDATA=^AFSHTEMP(AFSGCNT) U %DEV W AFSDATA,!
  1.  I AFSGCNT#100=0 U IO(0) W $J(AFSGCNT,8)
  1.  S AFSZCNT=AFSZCNT+1
  1.  G COPY2A
  1. COPY2END Q
  1. Q ;
  1.  D ^%ZISC
  1.  Q
  1.  ;      NEW SUBROUTINE ACR*2.0T1*16
  1.  ;
  1.  ;      X7 = UNIX TRANSMISSION FILE
  1.  ;
  1.  N ACRFMS,X,X3,X4,X5,X6
  1.  Q:'$D(^TMP("ACR",$J,"EXP"))
  1.  S X7=$P(AFSEXFN,"/",$L(AFSEXFN,"/"))
  1.  S ACRFMS=0
  1.  F  S ACRFMS=$O(^TMP("ACR",$J,"EXP",ACRFMS)) Q:'ACRFMS  D
  1.  . S X=^TMP("ACR",$J,"EXP",ACRFMS)
  1.  . S X3=$P(X,U)
  1.  . S X4=$P(X,U,2)
  1.  . S X5=$P(X,U,3)
  1.  . S X6=$P(X,U,4)
  1.  . D LINK^ACRFDHRE(ACRFMS,DT,X3,X4,X5,X6,X7)
  1.  K ^TMP("ACR",$J,"EXP")
  1.  Q