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

ACHSA7.m

Go to the documentation of this file. 
  1. ACHSA7 ; IHS/ITSC/PMF - ENTER DOCUMENTS (8/8)-(CONFIRM & RECORD) ;     [ 01/18/2005  11:51 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**1,11,12**;JUN 11, 2001
  1.  ;;ACHS*3.1*1  keep 4 digit fiscal year
  1.  ;ITSC/SET/JVK ACHS*3.1*11 MODIFIED FOR MEDICARE PROVIDER INFO
  1.  ;ITSC/SET/JVK ACHS*3.1*12 MODIFIED FOR DHHS CONTRACT INFO
  1.  ;
  1. A1 ;
  1.  K ACHSDIEN
  1.  S ACHSORDN="",ACHSODT=DT
  1.  ;ITSC/SET/JVK ACHS*3.1*12 ASK PROCUREMRNT INFO IF NOT 638 SITE 
  1.  S ACHSCTYP=""
  1.  I $P(^ACHSF(DUZ(2),0),U,8)'="Y" D CNTRCT
  1.  ;ITSC/SET/JVK END CHANGES
  1.  D ^ACHSAV                   ;DISPLAY DOCUMENT INFORMATION TO CONFIRM
  1.  S Y=$$DIR^XBDIR("Y","Is This Correct ","NO","","","",1)
  1.  I $D(DTOUT) D END Q
  1.  ;ITSC/SET/JVK ACHS*3.1*12 THIS IS A Y/N COMMENT OUT BELOW  
  1.  ;G A1:$D(DUOUT)
  1.  I 'Y S ACHSAFLG=1 G A1A^ACHSA     ;RESUME ENTRY OF DOCUMENT ASKING FOR FISCAL YEAR
  1.  D ERRCHK
  1.  I $D(ACHSOUT) D END S ACHSOUT=1 Q
  1.  D SB1                                         ;GO GET THE NEXT ACHSDIEN
  1.  ;                                              AND CREATE THE ENTRY 
  1.  I $D(ACHSCNC) S ACHSAFLG=1 G A1A^ACHSA
  1.  W *7,!!,"  Document #  ",ACHSORDN,"   Recorded",!!
  1.  D ACT^ACHSACT(ACHSDIEN,$$NOW^XLFDT,"<INITIAL>")    ;RECORD ACTION ON
  1.  ;                                                  DOCUMENT. IN THIS
  1.  ;                                                  CASE CREATE ONE
  1.  LOCK
  1.  I $G(ACHSREF) D STAT^ACHSBMC("A") D AUTH^ACHSBMC
  1.                             ;IN THE RCIS REFERRAL FILE
  1.  D LAD^ACHSVPS(ACHSPROV,DT) ;UPDATE 'LAST AUTH DATE' IN VENDOR FILE
  1. END ;
  1.  K ACHSREF,ACHSREFT,N
  1.  D END^ACHSA           ;KILL VARS
  1.  Q
  1.  ;
  1. SB1 ;
  1.  S ACHS("CHK")=1
  1.  D SBAENT^ACHSUUP                  ;Update Current Advice of Allowance
  1.                                    ;and Total Obligated FYTD
  1.  S ACHS("CHK")=0
  1.  I $D(ACHSCNC) D END S ACHSCNC=1 Q  ;SOME. IS WRONG SET FLAG AGAIN?????
  1.  ;
  1.  S ACHSDOCR=U_DT_U_$S($D(ACHSBLKF):1,$D(ACHSSLOC):2,1:0)_U_ACHSTYP_U_ACHSCONP_U_ACHSCAN_U_ACHSSCC_U_ACHSPROV_U_U_ACHSOBJC_U_U_"0"_U_ACHSCOPT
  1.  ;
  1.  ;12/3/01  pmf  keep the four digit fiscal year as well as the one digit  ACHS*3.1*1
  1.  ;S ACHSDOCR=ACHSDOCR_U_$E(ACHSACFY,4)_U_U_U_ACHSDEST_U_DUZ_U_ACHSDCR_U_ACHSPATF_U_ACHSHRN_U_$G(DFN)_U_ACHSAGRP_U_U_ACHSDRG ; ACHS*3.1*1
  1.  S ACHSDOCR=ACHSDOCR_U_$E(ACHSACFY,4)_U_U_U_ACHSDEST_U_DUZ_U_ACHSDCR_U_ACHSPATF_U_ACHSHRN_U_$G(DFN)_U_ACHSAGRP_U_U_ACHSDRG_U_U_ACHSACFY ; ACHS*3.1*1
  1.  ;
  1.  S ACHSTRAN=DT_U_"I"_U_$G(DFN)_U_ACHSESDO
  1.  ;
  1.  ;TRY AND LOCK DOCUMENT FILE IF CANNOT SET FLAG AND QUIT
  1.  I '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",0)","+") W !!,*7,"CHS FACILITY FILE IN USE BY ANOTHER PROCESS.",$$DIR^XBDIR("E") S ACHSCNC="" Q
  1.  ;
  1.  ;AGAIN HE BYPASSES FILEMAN AND MANUALLY SETS THE NEW RECORD
  1.  ;THIS CAN BE REPLACED WITH FILEMAN CALL ??????
  1.  S:'$D(^ACHSF(DUZ(2),"D",0)) ^ACHSF(DUZ(2),"D",0)=$$ZEROTH^ACHS(9002080,100)
  1.  S ACHSDIEN=+$P($G(^ACHSF(DUZ(2),"D",0)),U,3)
  1.  ;
  1. EIN S ACHSDIEN=ACHSDIEN+1
  1.  I $D(^ACHSF(DUZ(2),"D",ACHSDIEN)) G EIN    ;IEN IS IN USE. TRY AGAIN
  1.  ;
  1.  D CKB^ACHSUUP          ;CHECK BALANCES
  1.  ;
  1.  I $D(ACHSCNC) Q        ;IF BALANCES OUT OF SYNC CANCEL
  1.  ;
  1.  S $P(^ACHSF(DUZ(2),"D",0),U,3)=ACHSDIEN    ;LAST ASSIGNED IEN
  1.  ;ADD ONE TO TOTAL ENTRIES
  1.  S $P(^ACHSF(DUZ(2),"D",0),U,4)=$P($G(^ACHSF(DUZ(2),"D",0)),U,4)+1
  1.  ;
  1.  I '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",0)","-") W $$DIR^XBDIR("E") S ACHSCNC="" Q
  1.  I '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+") W $$DIR^XBDIR("E") S ACHSCNC="" Q
  1.  S ^ACHSF(DUZ(2),"D",ACHSDIEN,0)=ACHSDOCR
  1.  S ^ACHSF(DUZ(2),"D","B","1"_$E(ACHSACFY,4)_ACHSACN,ACHSDIEN)=""
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U)=ACHSACN
  1. 25 ; Fields 25, 26, 26.01
  1.  ;ITSC/SET/JVK ACHS*3.1*11 ADD NEW FIELD 26.02
  1.  ;S ^ACHSF(DUZ(2),"D",ACHSDIEN,1)=$G(ACHSESDA)_U_$G(ACHSDES)_U_$G(ACHSPAN)
  1.  S ^ACHSF(DUZ(2),"D",ACHSDIEN,1)=$G(ACHSESDA)_U_$G(ACHSDES)_U_$G(ACHSPAN)_U_$G(ACHSMPP)
  1. 50 ;
  1.  I ACHSTYP=3,ACHSHON]"" S ^ACHSF(DUZ(2),"D",ACHSDIEN,2)=ACHSHON
  1.  ;ITSC/SET/JVK ACHS*3.1*12
  1.  I $D(ACHSCAT) S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,2),U,9)=ACHSCAT
  1. 75 ;
  1.  S ^ACHSF(DUZ(2),"D",ACHSDIEN,3)=ACHSFDT_U_ACHSTDT_$S((ACHSTYP=2)!$D(ACHSBLKF)!$D(ACHSSLOC):"",1:U_U_U_ACHSRPHY_U_ACHSRMPC_U_$P(ACHSRCOI,U)_U_ACHSRALR)
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,9)=ACHSEDOS
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,10)=ACHSREFT
  1.  S ^ACHSF(DUZ(2),"ES",ACHSEDOS,ACHSDIEN)=""
  1. 84 ;
  1.  I $D(ACHSRDX) D
  1.  . S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,4,0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,4,0)=$$ZEROTH^ACHS(9002080,100,84)
  1.  . F ACHS=1:1 Q:'$D(ACHSRDX(ACHS))  S DIC="^ACHSF("_DUZ(2)_",""D"","_ACHSDIEN_",4,",DIC(0)="",DA(2)=DUZ(2),DA(1)=ACHSDIEN,X=+ACHSRDX(ACHS) K DO,DD D FILE^DICN
  1.  ;
  1. 85 ;
  1.  I $G(ACHSRDXN)]"" S ^ACHSF(DUZ(2),"D",ACHSDIEN,5)=ACHSRDXN
  1. 86 ;
  1.  I $D(ACHSRPX) D
  1.  . S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,6,0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,6,0)=$$ZEROTH^ACHS(9002080,100,86)
  1.  . F ACHS=1:1 Q:'$D(ACHSRPX(ACHS))  S DIC="^ACHSF("_DUZ(2)_",""D"","_ACHSDIEN_",6,",DIC(0)="",DA(2)=DUZ(2),DA(1)=ACHSDIEN,X=ACHSRPX(ACHS) K DO,DD D FILE^DICN
  1.  .Q
  1. 87 ;
  1.  I $G(ACHSRPXN)]"" S ^ACHSF(DUZ(2),"D",ACHSDIEN,7)=ACHSRPXN
  1.  I '$D(ACHSBLKF),'$D(ACHSSLOC) S ACHS("DX")=4,ACHS("PX")=6 D CDRG^ACHSPAM
  1.  ;
  1.  ;MANUALLY SET TRANSACTION RECORD ??????? BYPASSES FILEMAN
  1.  S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)=$$ZEROTH^ACHS(9002080,100,100)
  1.  S Y=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0))
  1. SBD1 ;
  1.  S M=$P(Y,U,3)+1,$P(Y,U,3)=M,$P(Y,U,4)=M
  1.  G SBD1:$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M))
  1.  S ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)=Y,^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M,0)=ACHSTRAN
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M,0),U,11)=DUZ
  1.  S:$D(DFN) ^ACHSF(DUZ(2),"PB",DFN,ACHSDIEN,M)=""
  1.  S ^ACHSF(DUZ(2),"TB",DT,"I",ACHSDIEN,M)=""
  1.  S:$D(ACHSPROV) ^ACHSF(DUZ(2),"VB",ACHSPROV,ACHSDIEN,M)=""
  1.  I $D(ACHSBLKF)!($D(ACHSSLOC)) S ^ACHSF(DUZ(2),"D",ACHSDIEN,"BT")=ACHSBLT
  1.  S ACHSTIEN=M
  1.  ;
  1.  D SBAENT^ACHSUUP          ;Update Current Advice of Allowance
  1.                            ;and Total Obligated FYTD
  1.  ;
  1.  I $D(ACHSCNC) D SBKILL Q  ;IF SOMETHING WRONG WITH BALANCES CANCEL SETS
  1.  ;
  1.  D SBQ^ACHSUUP             ;Place document in print list
  1.  Q
  1.  ;
  1. SBKILL ;
  1.  K ^ACHSF(DUZ(2),"D",ACHSDIEN)
  1.  S X=$P($G(^ACHSF(DUZ(2),"D",0)),U,3)        ;NEEDS RE-EVAL BIG TIME??????
  1.  S $P(^ACHSF(DUZ(2),"D",0),U,3)=X-1      ;LAST ENTRY USED. NOT
  1.                                          ;NECESSARILY -1 ??????
  1.  S $P(^ACHSAF(DUZ(2),"D",0),U,4)=X-1     ;NUMBER OF ENTRIES
  1.  I $D(^ACHS(9,DUZ(2),"FY",ACHSACFY,"C")) D
  1.  .S ^ACHS(9,DUZ(2),"FY",ACHSACFY,"C")=$G(^ACHS(9,DUZ(2),"FY",ACHSACFY,"C"))-1
  1.                                                  ;MAJOR LOGIC ERROR FOR
  1.                                                  ;TYPE SEQUENCE FIELDS
  1.                                                  ;??????
  1.  K ^ACHSF(DUZ(2),"ES",ACHSEDOS,ACHSDIEN)         ;THE FOLLOWING MANUALLY
  1.                                                  ;KILL THE X-REFS ??????
  1.  K ^ACHSF(DUZ(2),"PB",ACHSDIEN,ACHSTIEN)
  1.  K ^ACHSF(DUZ(2),"TB",DT,"I",ACHSDIEN,ACHSTIEN)
  1.  K ^ACHSF(DUZ(2),"VB",ACHSPROV,ACHSDIEN,ACHSTIEN)
  1.  K ^ACHSF(DUZ(2),"D","B",ACHSORDN)
  1.  Q
  1.  ;
  1. ERRCHK ;
  1.  K ACHSOUT
  1.  I '$D(ACHSHRN)!'$D(DFN) G ERRCHK1
  1.  I (+ACHSHRN)'=(+$$HRN^ACHS(DFN,ACHSPATF)) D
  1.  . W !!,*7,*7,"HEALTH RECORD NUMBER MISMATCH.  NOTIFY PROGRAMMER IMMEDIATELY."
  1.  . W !,"ACHSHRN=",ACHSHRN,"    PATIENT RECORD #=",$$HRN^ACHS(DFN,ACHSPATF),"    PATIENT FACILITY=",$P($G(^DIC(4,ACHSPATF,0)),U),!!!
  1.  . D RTRN^ACHS
  1.  ;
  1. ERRCHK1 ;
  1.  I '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSACFY,""C"")","+") G ERREND
  1.  S ACHSACN=$G(^ACHS(9,DUZ(2),"FY",ACHSACFY,"C"))
  1.  S ACHSACN=ACHSACN+1
  1.  S ACHSACN("NO")=ACHSACN
  1.  S ACHSACN=$E("00000",1,5-$L(ACHSACN))_ACHSACN
  1.  S ACHSORDN=$E(ACHSACFY,4)_"-"_$E("000",1,3-$L(ACHSFC))_ACHSFC_"-"_ACHSACN
  1.  S ACHSACN1="1"_$E(ACHSACFY,4)_ACHSACN
  1.  I '$D(^ACHSF(DUZ(2),"D","B",ACHSACN1)) D  Q
  1.  . S ^ACHS(9,DUZ(2),"FY",ACHSACFY,"C")=ACHSACN("NO")
  1.  . I '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSACFY,""C"")","-")
  1.  ;
  1.  ;
  1.  W *7,*7,!!?25,"ABORTED!!",!?3,"Document number ALREADY EXISTS. Cannot issue DUPLICATE DOCUMENT NUMBERS",!?20,"Please notify your site manager!"
  1. ERREND ;
  1.  W !
  1.  D RTRN^ACHS  ;PRESS RETURN TO CONT.
  1.  LOCK         ;UNLOCK EVERYTHING
  1.  S ACHSOUT=1
  1.  Q
  1.  ;
  1. CNTRCT ;
  1.  K DIR
  1.  S DIR(0)="P^9002068.1:EMZ"
  1.  S DIR("??")="^D DISCAT^ACHSA7"
  1.  S DIR("A")="Enter Contract Action Type"
  1.  D ^DIR
  1.  I Y="^",$D(DUOUT) W !,"Contract Action Type Required!",!,"Enter ?? for help.",! D CNTRCT
  1.  S ACHSCTYP=$P(Y,U),ACHSCAT=ACHSCTYP
  1. DISCAT ;EP - From call to DIR
  1.  W !
  1.  S %=0
  1.  F  S %=$O(^DD(9002068.1,.01,21,%)) Q:'%  W !,$G(^DD(9002068.1,.01,21,%,0)) I $G(^DD(9002068.1,.01,21,%+1,0))[" - " Q:'$$DIR^XBDIR("E","Press RETURN...")
  1.  Q