- ACHSRPF ; IHS/OIT/FCJ - PRINT CHS PO AND FORM ; 30 Jun 2011 10:08 AM
- ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,20**;JUN 11, 2001
- ;;ACHS*3.1*18 NEW ROUTINE TO SET TEMP GLOBAL TO BE CALLED BY INTERFACE RTN
- ;TO PRINT COMPLETE FORM AND DATA
- ;
- ;
- ;IF $D(ACHSRPNT) THEN it is a REPRINT
- ST ;
- K ^TMP("ACHSPO",$J)
- S (ACHSALL,ACHSREG,C)=0
- D ^ACHSVAR
- I $D(^ACHSESIG(DUZ(2))) S ACHSEFL=$P(^ACHSESIG(DUZ(2),0),U,2,3)
- ;INITIAL PRINT OR REPRINT
- D @$S('$D(ACHSRPNT):"I",1:"R")
- Q
- I ;
- I '$D(^ACHSF("PQ",DUZ(2))) S ACHSERR=1 Q
- I1 ;
- ;IF NOT A RE-PRINT SET UP NEW ENTRY IN 'CHS DOCUMENT PRINTED LIST'
- I '$$LOCK^ACHS("^ACHS(7)","+") W !,"LOCK FAILED AT B1+13^ACHSRP"
- ;GET 0 RECORD OF 'CHS DOCUMENT PRINTED LIST' FILE
- S X=$G(^ACHS(7,0))
- S ACHS7DA=$P(X,U,3)+1 ;MANUALLY INCREMENT # ENTRIES FIELD
- S ^ACHS(7,0)=$P(X,U,1,2)_U_ACHS7DA_U_ACHS7DA
- S ^ACHS(7,ACHS7DA,0)=IO_U_DT,^ACHS(7,ACHS7DA,"D",0)="^9002067.01^^",^ACHS(7,"CZ",9999999-DT,ACHS7DA)="",^ACHS(7,"B",IO,ACHS7DA)=""
- I '$$LOCK^ACHS("^ACHS(7)","-")
- ;
- ;
- I2 ;LOOP THROUGH THE PQ X-REF BASED ON THE TYPE OF SERVICE
- ;Index: ^ACHSF("PQ",FACILITY,TYPE OF SERVICE,DOC #,TRAN #
- S ACHSTYPV=0
- F S ACHSTYPV=$O(^ACHSF("PQ",DUZ(2),ACHSTYPV)) Q:ACHSTYPV'?1N.N D
- .S ACHSDIEN="" F S ACHSDIEN=$O(^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN)) Q:ACHSDIEN'?1N.N D Q:$G(Y)="X"
- ..S ACHSTIEN="" F S ACHSTIEN=$O(^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN)) Q:ACHSTIEN'?1N.N D Q:$G(Y)="X"
- ...I $D(ACHSEFL) D I ACHSEFLG S $P(ACHSEFL,U,3)=$P(ACHSEFL,U,3)+1,ACHSERR=2 Q
- ....S ACHSEFLG=0
- ....Q:$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)=2 ;DO NOT TST SPEC LOC
- ....Q:$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,12)>1 ;DO NOT TST CAN, PAR CAN OR PAID
- ....Q:$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,2)<$P(ACHSEFL,U,2) ;TEST E-SIG DT
- ....I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,28)'?1N.N S ACHSEFLG=1 Q ;TEST E-SIG ORD OFC
- ....I $P(ACHSEFL,U)=1,$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,30)'?1N.N S ACHSEFLG=1 ;TEST E-SIG AUTH OFC
- ...D DOC
- Q
- ;
- R ;RE-PRINT LOOP THROUGH LIST OF SELECTED DOCUMENTS OR REPRINT BATCH OPTION
- ;^TMP("ACHSRR",$J,FACILITY,TYPE OF SERVICE,DOC #,TRAN #
- S ACHSTYPV=0 F S ACHSTYPV=$O(^TMP("ACHSRR",$J,DUZ(2),ACHSTYPV)) Q:ACHSTYPV'?1N.N D
- .S ACHSDIEN=""
- .F S ACHSDIEN=$O(^TMP("ACHSRR",$J,DUZ(2),ACHSTYPV,ACHSDIEN)) Q:ACHSDIEN'?1N.N D Q:$G(Y)="X"
- ..S ACHSTIEN=""
- ..F S ACHSTIEN=$O(^TMP("ACHSRR",$J,DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN)) Q:ACHSTIEN'?1N.N D Q:$G(Y)="X"
- ...D DOC
- Q
- ;
- DOC ;BEGIN PROCESSING DOCUMENTS
- S ACHSACF=$S(ACHSTYPV=1:"Hospital Service",ACHSTYPV=3:"Outpatient Service",ACHSTYPV=2:"Dental Service",1:"")
- S ACHSREG=1 D ^ACHSRPF1
- I $D(^TMP("ACHSRR",$J)) S ACHSERR=3
- D END
- Q
- ;
- SB1 ;EP FROM ACHSRPFU
- ;GET FACILITY INFO
- K B
- D FAC^ACHSUDF ; GET MAILING ADDRESS AND PLACE IN B ARRAY
- D FC^ACHSUF ; GET FINANCE CODE
- Q
- ;
- END ;
- K B,DFN
- I $G(ACHSDUZ2) S ^TMP("ACHSDUZ2",$J)=ACHSDUZ2
- K T,T1,T2,T3,T4 S T=ACHSTYPV,T1=ACHSDIEN,T2=ACHSTIEN S:$D(ACHS7DA) T3=ACHS7DA S:$D(ACHSRPNT) T4=ACHSRPNT
- D EN^XBVK("ACHS") ;KILL VARS IN ACHS NAMESPACE
- D ^ACHSVAR ;RESET ACHS VARIABLES
- I $G(^TMP("ACHSDUZ2",$J)) S ACHSDUZ2=$G(^TMP("ACHSDUZ2",$J)) K ^($J)
- S ACHSTYPV=T,ACHSDIEN=T1,ACHSTIEN=T2 S:$D(T3) ACHS7DA=T3 S:$D(T4) ACHSRPNT=T4 K T,T1,T2,T3,T4
- Q
- ;
- ;
- ;ACHSERR=1 ;NO QUEUED DOCUMENTS
- ;ACHSERR=2 ;DOCUMENTS WITHOUT SIGNATURE
- ;ACHSERR=3 ;DOCUMENTS QUED, BUT NO DATA SET
- ACHSRPF ; IHS/OIT/FCJ - PRINT CHS PO AND FORM ; 30 Jun 2011 10:08 AM
- +1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,20**;JUN 11, 2001
- +2 ;;ACHS*3.1*18 NEW ROUTINE TO SET TEMP GLOBAL TO BE CALLED BY INTERFACE RTN
- +3 ;TO PRINT COMPLETE FORM AND DATA
- +4 ;
- +5 ;
- +6 ;IF $D(ACHSRPNT) THEN it is a REPRINT
- ST ;
- +1 KILL ^TMP("ACHSPO",$JOB)
- +2 SET (ACHSALL,ACHSREG,C)=0
- +3 DO ^ACHSVAR
- +4 IF $DATA(^ACHSESIG(DUZ(2)))
- SET ACHSEFL=$PIECE(^ACHSESIG(DUZ(2),0),U,2,3)
- +5 ;INITIAL PRINT OR REPRINT
- +6 DO @$SELECT('$DATA(ACHSRPNT):"I",1:"R")
- +7 QUIT
- I ;
- +1 IF '$DATA(^ACHSF("PQ",DUZ(2)))
- SET ACHSERR=1
- QUIT
- I1 ;
- +1 ;IF NOT A RE-PRINT SET UP NEW ENTRY IN 'CHS DOCUMENT PRINTED LIST'
- +2 IF '$$LOCK^ACHS("^ACHS(7)","+")
- WRITE !,"LOCK FAILED AT B1+13^ACHSRP"
- +3 ;GET 0 RECORD OF 'CHS DOCUMENT PRINTED LIST' FILE
- +4 SET X=$GET(^ACHS(7,0))
- +5 ;MANUALLY INCREMENT # ENTRIES FIELD
- SET ACHS7DA=$PIECE(X,U,3)+1
- +6 SET ^ACHS(7,0)=$PIECE(X,U,1,2)_U_ACHS7DA_U_ACHS7DA
- +7 SET ^ACHS(7,ACHS7DA,0)=IO_U_DT
- SET ^ACHS(7,ACHS7DA,"D",0)="^9002067.01^^"
- SET ^ACHS(7,"CZ",9999999-DT,ACHS7DA)=""
- SET ^ACHS(7,"B",IO,ACHS7DA)=""
- +8 IF '$$LOCK^ACHS("^ACHS(7)","-")
- +9 ;
- +10 ;
- I2 ;LOOP THROUGH THE PQ X-REF BASED ON THE TYPE OF SERVICE
- +1 ;Index: ^ACHSF("PQ",FACILITY,TYPE OF SERVICE,DOC #,TRAN #
- +2 SET ACHSTYPV=0
- +3 FOR
- SET ACHSTYPV=$ORDER(^ACHSF("PQ",DUZ(2),ACHSTYPV))
- IF ACHSTYPV'?1N.N
- QUIT
- Begin DoDot:1
- +4 SET ACHSDIEN=""
- FOR
- SET ACHSDIEN=$ORDER(^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN))
- IF ACHSDIEN'?1N.N
- QUIT
- Begin DoDot:2
- +5 SET ACHSTIEN=""
- FOR
- SET ACHSTIEN=$ORDER(^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN))
- IF ACHSTIEN'?1N.N
- QUIT
- Begin DoDot:3
- +6 IF $DATA(ACHSEFL)
- Begin DoDot:4
- +7 SET ACHSEFLG=0
- +8 ;DO NOT TST SPEC LOC
- IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)=2
- QUIT
- +9 ;DO NOT TST CAN, PAR CAN OR PAID
- IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,12)>1
- QUIT
- +10 ;TEST E-SIG DT
- IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,2)<$PIECE(ACHSEFL,U,2)
- QUIT
- +11 ;TEST E-SIG ORD OFC
- IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,28)'?1N.N
- SET ACHSEFLG=1
- QUIT
- +12 ;TEST E-SIG AUTH OFC
- IF $PIECE(ACHSEFL,U)=1
- IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,30)'?1N.N
- SET ACHSEFLG=1
- End DoDot:4
- IF ACHSEFLG
- SET $PIECE(ACHSEFL,U,3)=$PIECE(ACHSEFL,U,3)+1
- SET ACHSERR=2
- QUIT
- +13 DO DOC
- End DoDot:3
- IF $GET(Y)="X"
- QUIT
- End DoDot:2
- IF $GET(Y)="X"
- QUIT
- End DoDot:1
- +14 QUIT
- +15 ;
- R ;RE-PRINT LOOP THROUGH LIST OF SELECTED DOCUMENTS OR REPRINT BATCH OPTION
- +1 ;^TMP("ACHSRR",$J,FACILITY,TYPE OF SERVICE,DOC #,TRAN #
- +2 SET ACHSTYPV=0
- FOR
- SET ACHSTYPV=$ORDER(^TMP("ACHSRR",$JOB,DUZ(2),ACHSTYPV))
- IF ACHSTYPV'?1N.N
- QUIT
- Begin DoDot:1
- +3 SET ACHSDIEN=""
- +4 FOR
- SET ACHSDIEN=$ORDER(^TMP("ACHSRR",$JOB,DUZ(2),ACHSTYPV,ACHSDIEN))
- IF ACHSDIEN'?1N.N
- QUIT
- Begin DoDot:2
- +5 SET ACHSTIEN=""
- +6 FOR
- SET ACHSTIEN=$ORDER(^TMP("ACHSRR",$JOB,DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN))
- IF ACHSTIEN'?1N.N
- QUIT
- Begin DoDot:3
- +7 DO DOC
- End DoDot:3
- IF $GET(Y)="X"
- QUIT
- End DoDot:2
- IF $GET(Y)="X"
- QUIT
- End DoDot:1
- +8 QUIT
- +9 ;
- DOC ;BEGIN PROCESSING DOCUMENTS
- +1 SET ACHSACF=$SELECT(ACHSTYPV=1:"Hospital Service",ACHSTYPV=3:"Outpatient Service",ACHSTYPV=2:"Dental Service",1:"")
- +2 SET ACHSREG=1
- DO ^ACHSRPF1
- +3 IF $DATA(^TMP("ACHSRR",$JOB))
- SET ACHSERR=3
- +4 DO END
- +5 QUIT
- +6 ;
- SB1 ;EP FROM ACHSRPFU
- +1 ;GET FACILITY INFO
- +2 KILL B
- +3 ; GET MAILING ADDRESS AND PLACE IN B ARRAY
- DO FAC^ACHSUDF
- +4 ; GET FINANCE CODE
- DO FC^ACHSUF
- +5 QUIT
- +6 ;
- END ;
- +1 KILL B,DFN
- +2 IF $GET(ACHSDUZ2)
- SET ^TMP("ACHSDUZ2",$JOB)=ACHSDUZ2
- +3 KILL T,T1,T2,T3,T4
- SET T=ACHSTYPV
- SET T1=ACHSDIEN
- SET T2=ACHSTIEN
- IF $DATA(ACHS7DA)
- SET T3=ACHS7DA
- IF $DATA(ACHSRPNT)
- SET T4=ACHSRPNT
- +4 ;KILL VARS IN ACHS NAMESPACE
- DO EN^XBVK("ACHS")
- +5 ;RESET ACHS VARIABLES
- DO ^ACHSVAR
- +6 IF $GET(^TMP("ACHSDUZ2",$JOB))
- SET ACHSDUZ2=$GET(^TMP("ACHSDUZ2",$JOB))
- KILL ^($JOB)
- +7 SET ACHSTYPV=T
- SET ACHSDIEN=T1
- SET ACHSTIEN=T2
- IF $DATA(T3)
- SET ACHS7DA=T3
- IF $DATA(T4)
- SET ACHSRPNT=T4
- KILL T,T1,T2,T3,T4
- +8 QUIT
- +9 ;
- +10 ;
- +11 ;ACHSERR=1 ;NO QUEUED DOCUMENTS
- +12 ;ACHSERR=2 ;DOCUMENTS WITHOUT SIGNATURE
- +13 ;ACHSERR=3 ;DOCUMENTS QUED, BUT NO DATA SET
