- ACHSTXF1 ; IHS/OIT/FCJ - RE-EXPORT DATA - RECORD 2U(UFMS), SPECIFIC RECORDS AND BATCHES ;
- ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,15**;JUN 11,2001
- ;ACHS*3.1*14 IHS/OIT/FCJ New routine
- ; This routine is called from ACHSTXAR, for use with re-exporting
- ; specifically selected document transactions.
- ;
- D LINES^ACHSFU
- W @IOF,!,$$REPEAT^XLFSTR("*",80),!,$$C^XBFUNC("RE-EXPORT SELECTED CHS DATA"),!,$$REPEAT^XLFSTR("*"),!
- S ACHSCHSS=""
- D ^ACHSUF
- K ACHSCHSS
- I '$D(ACHS("REXNUM")) D KILLGLBS^ACHSTX S ACHSBDT=0,ACHSEDT=3990000
- S (J,ACHSDCR)=0,ACHSRR="",ACHSF638=$$PARM^ACHS(0,8)
- F ACHS=2:1:7 S ACHSRTYP(ACHS)=0
- W !?10,"FACILITY NAME: ",$$LOC^ACHS
- S2 ;
- S ACHSFDT=ACHSBDT
- S ACHSAFAC=$P(^AUTTLOC(DUZ(2),0),U,10)
- I $$PARM^ACHS(2,25)="Y" S X=$$PARM^ACHS(0,12) G AFACERR:+X<1 S ACHSAFAC=$P(^AUTTLOC(X,0),U,10)
- I +ACHSAFAC<1 G AFACERR
- I $$PARM^ACHS(2,9)="Y" F ACHS="252F","254V" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0))
- I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" F ACHS="252G","252R","254D","254L","254M" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0))
- I $D(ACHS("REXNUM")) G RXB
- S3 ;
- S ACHSBDT=$O(^TMP("ACHSTXAR",$J,ACHSBDT))
- G CVTEND1:ACHSBDT<1!(ACHSBDT>ACHSEDT)
- S ACHSLDAT=ACHSBDT
- S P=""
- S4 ;
- S P=$O(^TMP("ACHSTXAR",$J,ACHSBDT,P))
- G S3:P=""
- S (ACHSDOCR,ACHSDOCN,ACHSDOCT,ACHSIPA,ACHSDEST,ACHSCTY,ACHSDR3,ACHSTOS,ACHSDFY,X1)=""
- S (ACHSXLOC,ACHSCDE,ACHSARCO,ACHSPROV,ACHSFED,ACHSEIN,ACHSDUNS,ACHSCTYP)=""
- G S4:'$D(^ACHSF(DUZ(2),"D",P,0)) S ACHSDOCR=^(0)
- G S4:$P(ACHSDOCR,U,3)=2 ;skip special transactions
- S DA=0
- S5 ;
- S DA=$O(^TMP("ACHSTXAR",$J,ACHSBDT,P,DA))
- G S4:DA<1
- G S5:'$D(^ACHSF(DUZ(2),"D",P,"T",DA,0)) S ACHSDOCT=^(0)
- S ACHSTY=$P(ACHSDOCT,U,2)
- ;ACHS*3.1*15 3.9.2009 IHS.OIT.FCJ ADDED "P" TO NXT LINE
- G S5:ACHSTY="ZA"!(ACHSTY="IP")!(ACHSTY="P") ;skip paid documents
- D S7^ACHSTXF
- G S5
- ;
- RXB ;RE-EXPORT A BATCH
- ;
- S DA=0,P=0,ACHSTXDA=0,ACHSRCT=0
- F S ACHSTXDA=$O(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),2,ACHSTXDA)) Q:ACHSTXDA'?1N.N D
- .S P=$P(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),2,ACHSTXDA,0),U),DA=$P(^(0),U,2)
- .S (ACHSDOCR,ACHSDOCN,ACHSDOCT,ACHSIPA,ACHSDEST,ACHSCTY,ACHSDR3,ACHSTOS,ACHSDFY,X1)=""
- .S (ACHSXLOC,ACHSCDE,ACHSARCO,ACHSPROV,ACHSFED,ACHSEIN,ACHSDUNS,ACHSCTYP,ACHS2FY)=""
- .Q:'$D(^ACHSF(DUZ(2),"D",P,0)) S ACHSDOCR=^(0)
- .Q:$P(ACHSDOCR,U,3)=2 ;skip special transactions
- .Q:'$D(^ACHSF(DUZ(2),"D",P,"T",DA,0)) S ACHSDOCT=^(0)
- .S ACHSTY=$P(ACHSDOCT,U,2)
- .Q:ACHSTY="ZA"!(ACHSTY="IP") ;skip paid documents
- .D S7^ACHSTXF
- S ACHSFDT=$P(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),0),U,2),ACHSLDAT=$P(^(0),U,3)
- G CVTEND1
- ;
- AFACERR ;
- W !!,*7,*7,"AUTHORIZING FACILITY CODE ERROR - JOB CANCELLED"
- D ^%ZISC,KILL^ACHSTX8
- Q
- ;
- CVTEND1 ;
- S ACHSROUT=ACHSRCT
- S:ACHSRCT>2 ACHSROUT=ACHSRCT
- K ACHS2FY,ACHSDEST,ACHSDCR,ACHSF638,ACHSIPA,ACHSCAN,ACHSCDE,ACHSCTY,ACHSDOCN,ACHSDOCR,ACHSEFDT,ACHSPROV,ACHSFED,ACHSSCC,ACHSDOCT,ACHSTY,X1,ACHSXLOC
- G ^ACHSTX3
- ;
- ACHSTXF1 ; IHS/OIT/FCJ - RE-EXPORT DATA - RECORD 2U(UFMS), SPECIFIC RECORDS AND BATCHES ;
- +1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,15**;JUN 11,2001
- +2 ;ACHS*3.1*14 IHS/OIT/FCJ New routine
- +3 ; This routine is called from ACHSTXAR, for use with re-exporting
- +4 ; specifically selected document transactions.
- +5 ;
- +6 DO LINES^ACHSFU
- +7 WRITE @IOF,!,$$REPEAT^XLFSTR("*",80),!,$$C^XBFUNC("RE-EXPORT SELECTED CHS DATA"),!,$$REPEAT^XLFSTR("*"),!
- +8 SET ACHSCHSS=""
- +9 DO ^ACHSUF
- +10 KILL ACHSCHSS
- +11 IF '$DATA(ACHS("REXNUM"))
- DO KILLGLBS^ACHSTX
- SET ACHSBDT=0
- SET ACHSEDT=3990000
- +12 SET (J,ACHSDCR)=0
- SET ACHSRR=""
- SET ACHSF638=$$PARM^ACHS(0,8)
- +13 FOR ACHS=2:1:7
- SET ACHSRTYP(ACHS)=0
- +14 WRITE !?10,"FACILITY NAME: ",$$LOC^ACHS
- S2 ;
- +1 SET ACHSFDT=ACHSBDT
- +2 SET ACHSAFAC=$PIECE(^AUTTLOC(DUZ(2),0),U,10)
- +3 IF $$PARM^ACHS(2,25)="Y"
- SET X=$$PARM^ACHS(0,12)
- IF +X<1
- GOTO AFACERR
- SET ACHSAFAC=$PIECE(^AUTTLOC(X,0),U,10)
- +4 IF +ACHSAFAC<1
- GOTO AFACERR
- +5 IF $$PARM^ACHS(2,9)="Y"
- FOR ACHS="252F","254V"
- SET ACHS(ACHS)=$ORDER(^ACHS(3,DUZ(2),1,"B",ACHS,0))
- +6 IF ACHSF638="Y"
- IF $$PARM^ACHS(2,9)="Y"
- FOR ACHS="252G","252R","254D","254L","254M"
- SET ACHS(ACHS)=$ORDER(^ACHS(3,DUZ(2),1,"B",ACHS,0))
- +7 IF $DATA(ACHS("REXNUM"))
- GOTO RXB
- S3 ;
- +1 SET ACHSBDT=$ORDER(^TMP("ACHSTXAR",$JOB,ACHSBDT))
- +2 IF ACHSBDT<1!(ACHSBDT>ACHSEDT)
- GOTO CVTEND1
- +3 SET ACHSLDAT=ACHSBDT
- +4 SET P=""
- S4 ;
- +1 SET P=$ORDER(^TMP("ACHSTXAR",$JOB,ACHSBDT,P))
- +2 IF P=""
- GOTO S3
- +3 SET (ACHSDOCR,ACHSDOCN,ACHSDOCT,ACHSIPA,ACHSDEST,ACHSCTY,ACHSDR3,ACHSTOS,ACHSDFY,X1)=""
- +4 SET (ACHSXLOC,ACHSCDE,ACHSARCO,ACHSPROV,ACHSFED,ACHSEIN,ACHSDUNS,ACHSCTYP)=""
- +5 IF '$DATA(^ACHSF(DUZ(2),"D",P,0))
- GOTO S4
- SET ACHSDOCR=^(0)
- +6 ;skip special transactions
- IF $PIECE(ACHSDOCR,U,3)=2
- GOTO S4
- +7 SET DA=0
- S5 ;
- +1 SET DA=$ORDER(^TMP("ACHSTXAR",$JOB,ACHSBDT,P,DA))
- +2 IF DA<1
- GOTO S4
- +3 IF '$DATA(^ACHSF(DUZ(2),"D",P,"T",DA,0))
- GOTO S5
- SET ACHSDOCT=^(0)
- +4 SET ACHSTY=$PIECE(ACHSDOCT,U,2)
- +5 ;ACHS*3.1*15 3.9.2009 IHS.OIT.FCJ ADDED "P" TO NXT LINE
- +6 ;skip paid documents
- IF ACHSTY="ZA"!(ACHSTY="IP")!(ACHSTY="P")
- GOTO S5
- +7 DO S7^ACHSTXF
- +8 GOTO S5
- +9 ;
- RXB ;RE-EXPORT A BATCH
- +1 ;
- +2 SET DA=0
- SET P=0
- SET ACHSTXDA=0
- SET ACHSRCT=0
- +3 FOR
- SET ACHSTXDA=$ORDER(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),2,ACHSTXDA))
- IF ACHSTXDA'?1N.N
- QUIT
- Begin DoDot:1
- +4 SET P=$PIECE(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),2,ACHSTXDA,0),U)
- SET DA=$PIECE(^(0),U,2)
- +5 SET (ACHSDOCR,ACHSDOCN,ACHSDOCT,ACHSIPA,ACHSDEST,ACHSCTY,ACHSDR3,ACHSTOS,ACHSDFY,X1)=""
- +6 SET (ACHSXLOC,ACHSCDE,ACHSARCO,ACHSPROV,ACHSFED,ACHSEIN,ACHSDUNS,ACHSCTYP,ACHS2FY)=""
- +7 IF '$DATA(^ACHSF(DUZ(2),"D",P,0))
- QUIT
- SET ACHSDOCR=^(0)
- +8 ;skip special transactions
- IF $PIECE(ACHSDOCR,U,3)=2
- QUIT
- +9 IF '$DATA(^ACHSF(DUZ(2),"D",P,"T",DA,0))
- QUIT
- SET ACHSDOCT=^(0)
- +10 SET ACHSTY=$PIECE(ACHSDOCT,U,2)
- +11 ;skip paid documents
- IF ACHSTY="ZA"!(ACHSTY="IP")
- QUIT
- +12 DO S7^ACHSTXF
- End DoDot:1
- +13 SET ACHSFDT=$PIECE(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),0),U,2)
- SET ACHSLDAT=$PIECE(^(0),U,3)
- +14 GOTO CVTEND1
- +15 ;
- AFACERR ;
- +1 WRITE !!,*7,*7,"AUTHORIZING FACILITY CODE ERROR - JOB CANCELLED"
- +2 DO ^%ZISC
- DO KILL^ACHSTX8
- +3 QUIT
- +4 ;
- CVTEND1 ;
- +1 SET ACHSROUT=ACHSRCT
- +2 IF ACHSRCT>2
- SET ACHSROUT=ACHSRCT
- +3 KILL ACHS2FY,ACHSDEST,ACHSDCR,ACHSF638,ACHSIPA,ACHSCAN,ACHSCDE,ACHSCTY,ACHSDOCN,ACHSDOCR,ACHSEFDT,ACHSPROV,ACHSFED,ACHSSCC,ACHSDOCT,ACHSTY,X1,ACHSXLOC
- +4 GOTO ^ACHSTX3
- +5 ;