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

ACHSWDCS.m

Go to the documentation of this file. 
  1. ACHSWDCS ;IHS/OIT/FCJ-DCIS RECORD FOR EXPORT W/WEB FRS DATA;JUN 20, 2008 ; 17 Jul 2008  3:05 PM
  1.   ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,15,16**;JUN 11,2001
  1.   ;NEW ROUTINE FOR PATCH 14
  1.   ;ACHS*3.1*15 2.11.2009 IHS/OIT/FCJ ADDED TEST FOR UNDEF REQ DCIS FIELDS
  1.   ;ACHS*3.1*16 11.3.2009 IHS.OIT.FCJ TEST FOR BLANKET PO'S
  1.   ;;
  1. DCIS ;EP; RECORD FOR DCIS
  1. REC ;Record Type: Contract type PDO - 1, PDO>25K - 2, PDO<=25K - 3
  1.  S (ACHSRTYP,ACHSCTYP,ACHSCDFN,ACHSVC,ACHSVCL,X)=""
  1.  ;Test for PDO-task order and contract vendor DOS falls in the contract dates set to 1
  1.  ;ACHS*3.1*16 11.3.2009 IHS.OIT.FCJ ADDED NXT LINE FOR BLANKETS AND CHANGED 2ND LINE TO E
  1.  I $P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,3)=1 S ACHSCTYP="B"
  1.  E  S X=$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,2),U,9) I X?1N.N S ACHSCTYP=$P($G(^ACHSCTYP(X,0)),U,2)
  1.  S ACHSTST=0,ACHSCNU=""
  1.  S:ACHSCTYP="T" ACHSRTYP=1
  1.  I ACHSCTYP="T",$D(^AUTTVNDR(ACHSVDFN,"CN",0)) D
  1.  .;Test PO for contract vendor
  1.  .S ACHSCDFN=$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,5)
  1.  .I ACHSCDFN D CTST Q:ACHSTST
  1.  .;
  1.  .;If not in PO test vendor for valid contract
  1.  .S ACHSCDFN=0
  1.  .F  S ACHSCDFN=$O(^AUTTVNDR(ACHSVDFN,"CN",ACHSCDFN)) Q:ACHSCDFN'?1N.N  D CTST Q:ACHSTST
  1.  I 'ACHSTST S ACHSCNU="",ACHSRTYP=""
  1.  ;
  1.  ;f not a contract type PDO and PDO>25K type=2 or PDO<=25k type=3
  1.  I 'ACHSRTYP S ACHSRTYP=$S($P(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA"),U)>25000:2,1:3)
  1.  ;
  1. PIID ;PIID
  1.  S ACHSPIID=""
  1.  S ACHSPIID="HHSI"_$P(^ACHSF(ACHSFAC,0),U,11)_ACHSDFY_ACHSFC_ACHSDOC1_ACHSCTYP
  1.  S ACHSREC="^"_ACHSRTYP_"^"_ACHSPIID_"^^"_ACHSCNU
  1.  ;
  1.  ;E-SIG DATE For Date Signed and for Effective Date
  1.  S Y=$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,28)
  1.  S:Y?1N.N Y=$E(Y,1,3)+1700_$E(Y,4,7)
  1.  S ACHSREC=ACHSREC_"^"_Y_"^"_Y
  1.  S:'Y (ACHSERR(1),ACHSERR(2))=1  ;ACHS*3.1*15 2.11.2009 IHS/OIT/FCJ ERROR TEST
  1.  ;
  1.  ;Completion Date-AUTH END DATE
  1.  S Y=$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA"),U,3)
  1.  S:Y?1N.N Y=$E(Y,1,3)+1700_$E(Y,4,7)
  1.  S ACHSREC=ACHSREC_"^"_Y
  1.  S:'Y ACHSERR(3)=1  ;ACHS*3.1*15 2.11.2009 IHS/OIT/FCJ ERROR TEST
  1.  ;
  1.  ;Ultimate Completion Date-AUTH END DATE
  1.  I ACHSRTYP=3 S ACHSREC=ACHSREC_"^"
  1.  E  S ACHSREC=ACHSREC_"^"_Y S:'Y ACHSERR(4)=1 ;ACHS*3.1*15 2.11.2009 IHS/OIT/FCJ ERROR TEST
  1.  ;
  1.  ;Base Value Option <25K leave blank otherwise use TOT OBL
  1.  S X=""
  1.  I ACHSRTYP'=3 S X=$FNUMBER($P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,9),"",2)
  1.  S ACHSREC=ACHSREC_"^"_X
  1.  ;
  1.  ;Base Value Use TOT OBL
  1.  S X=""
  1.  S X=$FNUMBER($P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,9),"",2)
  1.  S ACHSREC=ACHSREC_"^"_X
  1.  ;
  1.  ;Area Contract number
  1.  S X=""
  1.  S X=$P(^ACHSF(ACHSFAC,0),U,11)
  1.  S ACHSREC=ACHSREC_"^"_X
  1.  ;
  1. CNTRC ;Type of Contract ***************MEDICARE QUESTIONS, DO WE NEED A CHECK FOR VALID DATES***********
  1.  S X=""
  1.  I (ACHSRTYP=1)!(ACHSRTYP=2) S X=$S($P($G(^AUTTVNDR(ACHSVDFN,23)),U)="Y":"J",1:"S")
  1.  S ACHSREC=ACHSREC_"^"_X
  1.  ;
  1.  ;Multi Year Contract
  1.  S X=""
  1.  I ACHSRTYP=2 S X=$S(ACHSCTYP="P":"N",1:"Y")
  1.  I ACHSRTYP=1,ACHSCNU S X=$S(ACHSVCL>365:"Y",1:"N")
  1.  S ACHSREC=ACHSREC_"^"_X
  1.  ;
  1. PSC ;Product or Service code
  1.  S X=""
  1.  I ACHSRTYP'=3 S X=$S(ACHSTOS=2:"Q503",1:"Q201")
  1.  S ACHSREC=ACHSREC_"^"_X
  1.  ;
  1.  ;NAICS Code
  1.  S X=""
  1.  I ACHSRTYP=2,$P(^ACHS(3,ACHSFAC,1,ACHSOBJ,0),U,6) S X=$P(^ACHS(3.1,$P(^ACHS(3,ACHSFAC,1,ACHSOBJ,0),U,6),0),U)
  1.  S ACHSREC=ACHSREC_"^"_X
  1.  ;
  1. DUNS ;DUNS Number
  1.  S X=""
  1.  ;ACHS*3.1*15 2.11.2009 IHS/OIT/FCJ DUNS WILL BE SENT FOR ALL RECORD TYPES, ALSO ADDED ERROR TST
  1.  ;I 'ACHSRTYP S X=$P(^AUTTVNDR(ACHSDFN,0),U,7)
  1.  S X=$P(^AUTTVNDR(ACHSVDFN,0),U,7) S:X="" ACHSERR(6)=1
  1.  S ACHSREC=ACHSREC_"^"_X
  1.  ;
  1.  ;Country of Orgin
  1.  S X=""
  1.  I ACHSRTYP=2 D
  1.  .S (X,X1)=""
  1.  .S X=$P($G(^AUTTVNDR(ACHSVDFN,24)),U)
  1.  .I X S X1=$P(^HL(779.004,X,0),U) S:X1="USA" X1="US"
  1.  .S X=$S(X1="US":X1,X1="CA":X1,X1="MX":X1,1:"")
  1.  S ACHSREC=ACHSREC_"^"_X
  1.  ;ACHS*3.1*15 2.11.2009 IHS/OIT/FCJ ADDED NXT LINE FOR PLACE OF PERF ERROR TEST
  1.  S:(X="CA")!(X="MX") ACHSERR(7)=""
  1.  ;
  1.  ;Business Size
  1.  S X=""
  1.  I ACHSRTYP'=1 D
  1.  .S Y=$P($G(^AUTTVNDR(ACHSVDFN,11)),U,26) S:Y'="" Y=$P(^AUTTVNDR(ACHSVDFN,11),U,22)
  1.  .S X=$S(Y=1:"S",Y=2:"O",1:"")
  1.  .I X="" S ACHSERR(9)=1 ;ACHS*3.1*15 2.11.2009 IHS/OIT/FCJ ADDED TEST FOR BUS SZ
  1.  S ACHSREC=ACHSREC_"^"_X
  1.  ;
  1.  ;Final Pay- Only sending Final pays
  1.  S ACHSREC=ACHSREC_"^Y"
  1.  ;
  1.  D CHK^ACHSWDR  ;ACHS*3.1*15 2.11.2009 IHS/OIT/FCJ TEST FOR ERRORS
  1.  ;
  1.  Q
  1. CTST ;Test for valid contract with DOS
  1.  S ACHSVC=^AUTTVNDR(ACHSVDFN,"CN",ACHSCDFN,0)
  1.  S ACHSCNU=$P(ACHSVC,U),(X2,ACHSBDT)=$P(ACHSVC,U,2),(X1,ACHSEDT)=$P(ACHSVC,U,3)
  1.  D ^%DTC S ACHSVCL=X
  1.  S ACHSEDT=ACHSEDT+1
  1.  I ACHSDOS=ACHSBDT S ACHSTST=1 Q
  1.  I ACHSDOS>ACHSBDT,ACHSDOS<ACHSEDT S ACHSTST=1
  1.  Q