source: WorldVistAEHR/trunk/r/GENERIC_CODE_SHEET-GEC/GECSVFY1.m@ 1226

GECSVFY1 ;WISC/RFJ-verify and check code sheet parameters (check)   ;18 Nov 93
 ;;2.0;GCS;;MAR 14, 1995
 Q
 ;
 ;
CHECK ;  check batch type
 N %,GECSDA,GECSDA1,GECSD1,GECSDIE,GECSDOM,X
 S %="",$P(%,"-",80)=""
 W !,%,!,"checking batch type: ",$P(GECSD,";")
 S GECSFLAG=0,GECSERR=1
 S GECSDA=+$O(^GECS(2101.1,"B",$P(GECSD,";"),0)),GECSD1=$G(^GECS(2101.1,GECSDA,0))
 ;  batch type not in file, add it
 I GECSD1="" D  Q:GECSFLAG
 .   W !?5,$J(GECSERR,2),".  ERROR -- BATCH TYPE NOT FOUND IN FILE 2101.1" I 'GECSFIX S GECSFLAG=1 Q
 .   N D0,DA,DD,DI,DIC,DIE,DQ,DR,DLAYGO,X,Y
 .   S DIC="^GECS(2101.1,",DIC(0)="L",DLAYGO=2101.1,X=$P(GECSD,";"),DIC("DR")="2///"_$P(GECSD,";",2)_";3///"_$P(GECSD,";",3) D FILE^DICN
 .  I Y<1 S GECSFLAG=1 W !?10,"*** UNABLE TO ADD BATCH TYPE TO FILE 2101.1." Q
 .   S GECSDA=+Y,GECSD1=^GECS(2101.1,GECSDA,0) W !?10,"... BATCH TYPE ADDED TO FILE 2101.1."
 ;
 S GECSDIE=""
 I $P(GECSD,";",2)'=$P(GECSD1,"^",3) D
 .   W !?5,$J(GECSERR,2),".  ERROR -- MAX CODE SHEETS PER MESSAGE SHOULD EQUAL '",$P(GECSD,";",2),"' [NOT '",$P(GECSD1,"^",3),"']" S GECSERR=GECSERR+1
 .   I GECSFIX S GECSDIE=$P(GECSD,";",2) W !?10,"... FIXING MAX CODE SHEETS PER MESSAGE."
 I $P(GECSD,";",3)'=$P(GECSD1,"^",4) D
 .   W !?5,$J(GECSERR,2),".  ERROR -- SYSTEM ID SHOULD EQUAL '",$P(GECSD,";",3),"' [NOT '",$P(GECSD1,"^",4),"']" S GECSERR=GECSERR+1
 .   I GECSFIX S $P(GECSDIE,"^",2)=$P(GECSD,";",3) W !?10,"... FIXING SYSTEM ID."
 I GECSFIX,GECSDIE'="" D
 .   N D,D0,DA,DI,DIC,DIE,DQ,DR,X
 .   S DR="" I $P(GECSDIE,"^")'="" S DR="2///"_$P(GECSDIE,"^")_";"
 .   I $P(GECSDIE,"^",2)'="" S DR=DR_"3///"_$P(GECSDIE,"^",2)
 .   S (DIC,DIE)="^GECS(2101.1,",DA=GECSDA D ^DIE
 ;
 I '$D(^GECS(2101.1,GECSDA,2,0)) S ^(0)="^2101.12^^"
 S GECSDIE="",GECSDA1=+$O(^GECS(2101.1,GECSDA,2,"B","XXX",0)),GECSD1=$G(^GECS(2101.1,GECSDA,2,GECSDA1,0))
 I GECSD1="" D  Q:GECSFLAG
 .   W !?5,$J(GECSERR,2),".  ERROR -- RECEIVING USER SHOULD EQUAL 'XXX'" S GECSERR=GECSERR+1
 .   I 'GECSFIX S GECSFLAG=1 Q
 .   N D0,DA,DD,DI,DIC,DIE,DQ,DR,DLAYGO,X,Y
 .   S (DA,DA(1))=GECSDA,DIC="^GECS(2101.1,"_DA_",2,",DIC(0)="L",DLAYGO=2101.1,X="XXX",DIC("DR")="2///Y" D FILE^DICN
 .   I Y<1 S GECSFLAG=1 W !?10,"*** UNABLE TO ADD RECEIVING USER 'XXX'." Q
 .   S GECSDA1=+Y,GECSD1=^GECS(2101.1,GECSDA,2,GECSDA1,0) W !?10,"... RECEIVING USER 'XXX' ADDED."
 ;
 ;  check to make sure domain is in domain file
 S X=$P(GECSD,";",4),X=$O(^DIC(4.2,"B",X,0))
 I X="" D  Q:GECSFLAG
 .   W !?5,$J(GECSERR,2),".  ERROR -- DOMAIN '",$P(GECSD,";",4),"' NOT FOUND IN DOMAIN FILE." S GECSERR=GECSERR+1
 .   I 'GECSFIX S GECSFLAG=1 Q
 .   N D0,DA,DD,DI,DIC,DIE,DQ,DR,DLAYGO,X,Y
 .   S DIC="^DIC(4.2,",DIC(0)="L",DLAYGO=4.2,X=$P(GECSD,";",4),DIC("DR")="1///S;2///FOC-AUSTIN.VA.GOV" D FILE^DICN
 .   I Y<1 W !?10,"*** UNABLE TO ADD DOMAIN TO DOMAIN FILE." S GECSFLAG=1 Q
 .   W !?10,"... DOMAIN ADDED TO DOMAIN FILE."
 ;
 S GECSDOM=$P($G(^DIC(4.2,+$P(GECSD1,"^",2),0)),"^")
 I $P(GECSD,";",4)'=GECSDOM D
 .   W !?5,$J(GECSERR,2),".  ERROR -- DOMAIN MAIL ROUTER SHOULD EQUAL '",$P(GECSD,";",4),"' " W:$L(GECSDOM)>5 !?46 W "[NOT '",GECSDOM,"']" S GECSERR=GECSERR+1
 .   I GECSFIX S $P(GECSDIE,"^")=$P(GECSD,";",4) W !?10,"... FIXING DOMAIN MAIL ROUTER."
 I $P(GECSD1,"^",3)'=1 D
 .   W !?5,$J(GECSERR,2),".  ERROR -- TRANSMIT SHOULD BE 'YES' [NOT 'NO']" S GECSERR=GECSERR+1
 .   I GECSFIX S $P(GECSDIE,"^",2)="Y" W !?10,"... FIXING TRANSMIT (TO YES)."
 I GECSFIX,GECSDIE'="" D
 .   N D,D0,DA,DI,DIC,DIE,DQ,DR,X
 .   S DR="" I $P(GECSDIE,"^")'="" S DR="1///"_$P(GECSD,";",4)_";"
 .   I $P(GECSDIE,"^",2)'="" S DR=DR_"2///1"
 .   S (DIE,DIC)="^GECS(2101.1,"_GECSDA_",2,",DA(1)=GECSDA,DA=GECSDA1 D ^DIE
 ;
 S X=$P($P($P(GECSD,";",4),"-",2),".",1)
 I X="" W !?5,$J(GECSERR,2),".  ERROR -- NO MAIL GROUP DEFINED." S GECSERR=GECSERR+1 Q
 S DIC="^XMB(3.8,",DIC(0)="X" D ^DIC I Y<0 W !?5,$J(GECSERR,2),".  ERROR -- THE MAIL GROUP '",X,"' NEEDS TO BE SET UP." S GECSERR=GECSERR+1
 Q