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