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

ACRFDOCN.m

Go to the documentation of this file. 
  1. ACRFDOCN ;IHS/OIRM/DSD/THL,AEF - SET DOCUMENT NUMBER; [ 11/30/2006   9:44 AM ]
  1.  ;;2.1;ADMIN RESOURCE MGT SYSTEM;**22**;NOV 05, 2001
  1.  ;;ROUTINE USED TO CREATE DOCUMENT NUMBER
  1. DOC ;EP;TO ASSIGN DOCUMENT NUMBERS
  1.  I $D(ACRAMEND),$D(^ACRDOC(ACRAMEND,0)) D DOCAMEND Q
  1.  S ACRREF=$P(^AUTTDOCR(ACRREFDA,0),U)
  1.  I ACRREF=130!(ACRREF=600) D  Q
  1.  .S ACRREF=130
  1.  .D TO
  1. PONUM1 I "^103^210^"[(U_ACRREF_U) D
  1.  .N ACRFY
  1.  .S ACRFY=$P(^ACRLOCB($P(ACRDOC0,U,6),"DT"),U)
  1.  .S ACRFYX=$S(+$E(DT,4,5)<10:$E(DT,1,3),1:$E(DT,1,3)+1) S ACRFYX=ACRFYX+1700
  1.  .S ACRFYX=$S(ACRFYX>ACRFY:ACRFYX,1:ACRFY)
  1.  .I '$D(^ACRPO(ACRPODA,1,0)) S ^ACRPO(ACRPODA,1,0)="^9002199.41"
  1.  .I '$D(^ACRPO(ACRPODA,1,"B",ACRFYX)) D
  1.  ..S (X,DINUM)=ACRFYX
  1.  ..S DA(1)=ACRPODA
  1.  ..S DIC="^ACRPO("_DA(1)_",1,"
  1.  ..S DIC(0)="L"
  1.  ..D FILE^ACRFDIC
  1.  .L +^ACRPO(ACRPODA):2
  1.  .I $T=1 S ACRTXDOC=$P(^ACRPO(ACRPODA,1,ACRFYX,0),U,2),ACRTXDOC=ACRTXDOC+1,$P(^(0),U,2)=ACRTXDOC L -^ACRPO(ACRPODA):0
  1.  .E  G PONUM1
  1.  .F ACRJI=1:1:(4-$L(ACRTXDOC)) S ACRTXDOC="0"_ACRTXDOC
  1.  .S ACRTXDOC=ACRTXDOC_"00"
  1.  S ACRTXPFX=$P(^ACRTXTYP(ACRTXDA,"DT"),U,2)
  1.  S ACRDPTDA=$P(^ACRLOCB(ACRFDNO,0),U,5)
  1.  S ACRLCOD=$P(^ACRLOCB(ACRFDNO,"DT"),U,11)
  1.  S ACRDEPT=$P(^AUTTPRG(ACRDPTDA,0),U,2)
  1.  S ACRPDA=$P(^ACRCAN(ACRCANDA,"DFLT1"),U,15)
  1.  S ACRAREA=$S('ACRPDA:"",$D(^ACRPO(ACRPDA,0)):$P(^(0),U,10),1:"")
  1.  I 'ACRPDA D  Q
  1.  .W *7,*7
  1.  .W !!,"The Purchasing Office for the CAN NO. default data has not been defined."
  1.  .W !,"Notify the ARMS systems manager immediately."
  1.  .D PAUSE^ACRFWARN
  1.  .S ACRQUIT=""
  1.  I 'ACRAREA D  Q
  1.  .W *7,*7
  1.  .W !!,"The Area Office of your Purchasing Office has not been identified."
  1.  .W !,"Notify the ARMS systems manager immediately."
  1.  .S ACRQUIT=""
  1.  .D PAUSE^ACRFWARN
  1.  I 'ACRLCOD D  Q
  1.  .W *7,*7
  1.  .W !!,"The location code of your Purchasing Office has not been identified."
  1.  .W !,"Notify the ARMS systems manager immediately."
  1.  .D PAUSE^ACRFWARN
  1.  .S ACRQUIT=""
  1.  S ACRLCOD=$P(^AUTTLCOD(ACRLCOD,0),U)
  1.  S ACRAREA=$P(^AUTTAREA(ACRAREA,0),U,3)
  1.  G:"^103^210^"[(U_ACRREF_U) DOC3
  1. DOC1 ;EP;
  1.  S ACRFY=$P(^ACRLOCB(ACRFDNO,"DT"),U)
  1.  S ACRFYX=$S(+$E(DT,4,5)<10:$E(DT,1,3),1:$E(DT,1,3)+1) S ACRFYX=ACRFYX+1700
  1.  S ACRFYX=$S(ACRFYX>ACRFY:ACRFYX,1:ACRFY)
  1.  I '$D(^ACRDEPT(ACRDPTDA,0)) D
  1.  .S (X,DINUM)=ACRDPTDA
  1.  .S DIC="^ACRDEPT(",DIC(0)="L"
  1.  .D FILE^ACRFDIC
  1.  I '$D(^ACRDEPT(ACRDPTDA,1,0)) S ^ACRDEPT(ACRDPTDA,1,0)="^9002188.11"
  1.  I '$D(^ACRDEPT(ACRDPTDA,1,ACRFYX,0)) D
  1.  .S DA(1)=ACRDPTDA
  1.  .S (DINUM,X)=ACRFYX
  1.  .S (ACRDIC,DIC)="^ACRDEPT("_DA(1)_",1,"
  1.  .S DIC(0)="L"
  1.  .D FILE^ACRFDIC
  1.  I '$D(^ACRDEPT(ACRDPTDA,1,ACRFYX,1,0)) S ^ACRDEPT(ACRDPTDA,1,ACRFYX,1,0)="^9002188.112P"
  1.  I '$D(^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA)) D
  1.  .S DA(2)=ACRDPTDA
  1.  .S DA(1)=ACRFYX
  1.  .S (DINUM,X)=ACRREFDA
  1.  .S (ACRDIC,DIC)="^ACRDEPT("_DA(2)_",1,"_DA(1)_",1,"
  1.  .S DIC(0)="L"
  1.  .D FILE^ACRFDIC
  1. DOC11 L +^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA,0):2
  1.  I $T=1 D  I 1
  1.  .S ACRTXDOC=$P(^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA,0),U,2)
  1.  .S ACRTXDOC=ACRTXDOC+1
  1.  .S $P(^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA,0),U,2)=ACRTXDOC
  1.  .L -^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA,0):0
  1.  E  G DOC11
  1.  F ACRJI=1:1:(4-$L(ACRTXDOC)) S ACRTXDOC="0"_ACRTXDOC
  1.  K ACRJI
  1. DOC3 S ACRFY=$P(^ACRLOCB(ACRZDA,"DT"),U)
  1.  S ACRFYX=$S(+$E(DT,4,5)<10:$E(DT,1,3),1:$E(DT,1,3)+1) S ACRFYX=ACRFYX+1700
  1.  S ACRFYX=$S(ACRFYX>ACRFY:ACRFYX,1:ACRFY)
  1.  S ACRDOC=$S(ACRREF=116!(ACRREF=101):ACRLCOD_"-"_ACRDEPT_"-"_$E(ACRFYX,4)_"-"_ACRTXDOC,ACRREF=103!(ACRREF=210):$E(ACRFYX,4)_ACRAREA_ACRLCOD_ACRTXDOC,1:$E(ACRFYX,4)_ACRTXPFX_ACRDEPT_ACRTXDOC)
  1.  ;I "^103^210^"'[(U_ACRREF_U),$D(^ACRDOC("B",ACRDOC)) G DOC11             ;ACR*2.1*22.07 IM22855
  1.  ;I "^103^210^"[(U_ACRREF_U),$D(^ACRDOC("B",ACRDOC))!$D(^ACRDOC("C",ACRDOC)) G DOC11    ;ACR*2.1*22.07 IM22855
  1.  I $D(^ACRDOC("B",ACRDOC))!($D(^ACRDOC("C",ACRDOC)))!($D(^ACRDOC("O",ACRDOC))) G DOC11  ;ACR*2.1*22.07 IM22855
  1.  K ACRFYX
  1.  Q
  1. TO ;EP;
  1.  N ACRFY
  1.  S ACRFY=$P(^ACRLOCB(ACRFDNO,"DT"),U)
  1.  S ACRLC=$P(^ACRLOCB(ACRFDNO,"DT"),U,11)
  1.  S ACRFYX=$S(+$E(DT,4,5)<10:$E(DT,1,3),1:$E(DT,1,3)+1) S ACRFYX=ACRFYX+1700
  1.  S ACRFYX=$S(ACRFYX>ACRFY:ACRFYX,1:ACRFY)
  1.  I '$D(^ACRPO(1,20,0)) S ^ACRPO(1,20,0)="^9002199.4201"
  1.  I '$D(^ACRPO(1,20,"B",ACRFY)) D
  1.  .S DA(1)=1
  1.  .S (X,DINUM)=ACRFY
  1.  .S DIC="^ACRPO(1,20,"
  1.  .S DIC(0)="L"
  1.  .S DIC("DR")=".02///0"
  1.  .D FILE^ACRFDIC
  1. TO1 L +^ACRPO(1):2
  1.  I $T=1 D  I 1
  1.  .S ACRNUM=$P(^ACRPO(1,20,ACRFY,0),U,2)
  1.  .S ACRNUM=ACRNUM+1
  1.  .S $P(^ACRPO(1,20,ACRFY,0),U,2)=ACRNUM
  1.  .S ACRAPT=$P(^ACRPO(1,0),U,4)
  1.  .S ACRAREA=$P(^ACRPO(1,0),U,10)
  1.  .L -^ACRPO(1):0
  1.  E  G TO1
  1.  F ACRJI=1:1:(4-$L(ACRNUM)) S ACRNUM="0"_ACRNUM
  1.  S (ACRDOC,ACRNUM)=$E(ACRFYX,4)_$E($P(^AUTTLCOD(ACRLC,0),U),1,3)_"TO"_ACRNUM
  1.  I $D(^ACRDOC("B",ACRNUM)) G TO1
  1.  K ACRFYX
  1.  Q
  1. DOCAMEND L +^ACRDOC(ACRAMEND,0):2
  1.  G:'$T DOCAMEND
  1.  S X=$P(^ACRDOC(ACRAMEND,0),U,9)
  1.  S X=X+1
  1.  S $P(^ACRDOC(ACRAMEND,0),U,9)=X
  1.  L -^ACRDOC(ACRAMEND,0):0
  1.  F Y=1:1:3-$L(X) S X="0"_X
  1.  N ACRREFDA,ACRREF
  1.  S ACRDOC=$P(^ACRDOC(ACRAMEND,0),U)_X
  1.  S ACRANUM=X
  1.  S ACRDOC2=$P(^ACRDOC(ACRAMEND,0),U,2)
  1.  S ACRREFDA=$P(^ACRDOC(ACRAMEND,0),U,13)
  1.  S ACRREF=$P(^AUTTDOCR(ACRREFDA,0),U)
  1.  Q