ACHSSVRP ; IHS/ITSC/PMF - SELECT AND PRINT AO SPECIAL VENDOR REPORT ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
S (ACHSFAC,ACHSNMS,ACHSSEQ)="",(ACHSEIN,ACHSDCNT,ACHSPGNO)=0
S ACHSDATE=$$HTE^XLFDT($H)
B1 ;
S ACHSEIN=$O(^ACHSSVR(ACHSEIN))
G PRTEND:+ACHSEIN=0
S DIC="^AUTTVNDR(",DIC(0)="",X=ACHSEIN,D="E"
D IX^DIC
I +Y<1 U IO(0) W "VENDOR LOOKUP ERROR FOR EIN # ",ACHSEIN U IO G B1
S ACHSEINP=+Y
I '$D(^ACHSSVR(ACHSEIN,"N")) D INDEX
D FAX,PGHDR
S ACHSFAC=""
B2 ;
S ACHSFAC=$O(^ACHSSVR(ACHSEIN,"N",ACHSFAC))
G B1:+ACHSFAC=0
S ACHSNMS=""
B3 ;
S ACHSNMS=$O(^ACHSSVR(ACHSEIN,"N",ACHSFAC,ACHSNMS))
G B2:ACHSNMS=""
S ACHSSEQ=""
B4 ;
S ACHSSEQ=$O(^ACHSSVR(ACHSEIN,"N",ACHSFAC,ACHSNMS,ACHSSEQ))
G B3:+ACHSSEQ=0
S ACHSX=$G(^ACHSSVR(ACHSEIN,ACHSFAC,ACHSSEQ))
K DIC
S DIC="^AUTTLOC(",D="C",DIC(0)="",X=ACHSFAC
D IX^DIC
I +Y<1 U IO(0) W "INVALID FACILITY CODE" S ACHSFACN="UNKNOWN FAC CODE" U IO G B5
S ACHSFACN=$E($P($G(^DIC(4,+Y,0)),U),1,12)
B5 ;
I $Y>55 D PGHDR
S X=ACHSX
W ACHSFACN,?14,$E($E(X,103,122),1,16),?32,$E(X,4,4),"-",$E(X,5,7),"-",$E(X,8,12),?45,$E(X,13,14),"-",$E(X,67,67),?51,$E(X,34,39),?59
S ACHSDCNT=ACHSDCNT+1
W $E(X,63,64),"/",$E(X,65,66),"/",$E(X,61,62),?70
S V=$E(X,69,76)/100
W $J(V,9,2),!?14,"TRIBE-CD=",$E(X,151,153)," COMM-CD=",$E(X,154,160),!
I $E(X,119,119)=" "!($E(X,119,119)="") W ! G B4
W ?14,"<",$E(X,119,134),">",!
I $E(X,135,136)=" " W !! G B4
W ?14,"<",$E(X,135,150),">",!!
G B4
;
PRTEND ; Print totals.
U ACHSPTR
W !,$$REPEAT^XLFSTR("-",70),!!?10,"TOTAL DOCUMENTS LISTED = ",ACHSDCNT
ZEND ;
I $D(IO),IO D ^%ZISC
ZENDA ;
K X,Y,ACHSEIN
Q
;
PGHDR ;
U ACHSPTR
S ACHSPGNO=ACHSPGNO+1
W @IOF,$$C^XBFUNC("CHS AUTHORIZATIONS FROM "_$$LOC^ACHS_" FACILITIES",80)
W !,$$C^XBFUNC("FOR "_$P($G(^AUTTVNDR(ACHSEINP,0)),U),80)
S Z=^ACHSSVR(ACHSEIN,0),A=$P(Z,U,1),A=$E(A,3,4)_"/"_$E(A,5,6)_"/"_$E(A,1,2),B=$P(Z,U,2),B=$E(B,3,4)_"/"_$E(B,5,6)_"/"_$E(B,1,2)
W !,$$C^XBFUNC("FOR AUTHORIZATIONS ISSUED BETWEEN "_A_" AND "_B,80)
W !,ACHSDATE,?70,"PAGE ",ACHSPGNO,!!!,$$REPEAT^XLFSTR("-",80),!,"LOCATION",?14,"PATIENT NAME",?32,"DOCUMENT #",?45,"TYPE",?51,"IHS #",?59,"AUTH DTE",?70,"$$ AMOUNT",!,$$REPEAT^XLFSTR("-",80),!
Q
;
FAX ; Print FAX cover sheet for vendor.
U ACHSPTR
W @IOF
F I=1:1:5 W !
W $$C^XBFUNC("INDIAN HEALTH SERVICE",80)
W !,$$C^XBFUNC($$LOC^ACHS,80)
W !,$$C^XBFUNC($P(^AUTTLOC(DUZ(2),0),U,12),80)
S X=$P(^AUTTLOC(DUZ(2),0),U,13),Y=$P(^AUTTLOC(DUZ(2),0),U,14),Z=$P(^DIC(5,+Y,0),U,2)
W !,$$C^XBFUNC(X_", "_Z_" "_$P(^AUTTLOC(DUZ(2),0),U,15),80)
W !!!!!!?10,"DATE: ",$$FMTE^XLFDT(DT)
W !!!!?10,"DELIVER TO:",?25,$E($P(^AUTTVNDR(ACHSEINP,0),U,1),1,30)
W !?25,$P(^AUTTVNDR(ACHSEINP,13),U,1)
W !?25,$P(^AUTTVNDR(ACHSEINP,13),U,2)," "
S Y=$P(^AUTTVNDR(ACHSEINP,13),U,3),Z=$P(^DIC(5,+Y,0),U,2)
W Z," ",$P(^AUTTVNDR(ACHSEINP,13),U,4)
W !!!!?10,"FAX #: ",?25,$P(^AUTTVNDR(ACHSEINP,11),U,14)
W !!!!!!!?10,"FROM: ",?25,"Contract Health Services"
W !?25,$E($$LOC^ACHS,1,30)
W !!!!!!?10,"SUBJECT: ",?25,"CHS PURCHASE ORDERS"
W !!
Q
;
INDEX ; Create print index for ^ACHSSVR & Begin & End date.
S ACHSI="",ACHSJ=1,ACHSK=""
S:'$D(^ACHSSVR(ACHSEIN,0)) ^ACHSSVR(ACHSEIN,0)="999999^0"
INDEXB ;
S ACHSJ=$O(^ACHSSVR(ACHSEIN,ACHSJ))
G INDEXZ:ACHSJ=""!(+ACHSJ=0)
INDEXC ;
;BEGIN Y2K BLOCK
S ACHSK=$O(^ACHSSVR(ACHSEIN,ACHSJ,ACHSK))
G INDEXB:ACHSK=""!(+ACHSK=0)
S ACHSX=$G(^ACHSSVR(ACHSEIN,ACHSJ,ACHSK))
S ACHSPNAM=$E(ACHSX,103,118)
S:ACHSPNAM="" ACHSPNAM=" "
S ^ACHSSVR(ACHSEIN,"N",ACHSJ,ACHSPNAM,ACHSK)="",ACHSADT=$E(ACHSX,61,66)
S ACHSADT=$S($E(ACHSADT,1,2)<84:20000000,1:19000000)+ACHSADT
S X=$P($G(^ACHSSVR(ACHSEIN,0)),U) ;XXX-0999-200030
S X=$S($E(X,1,2)<84:20000000,1:19000000)+X
S:ACHSADT<X $P(^ACHSSVR(ACHSEIN,0),U)=$E(ACHSADT,3,8)
S X=$S($E(X,1,2)<84:20000000,1:19000000)+X
S:ACHSADT>X $P(^ACHSSVR(ACHSEIN,0),U,2)=$E(ACHSADT,3,8) ;
;END Y2K BLOCK
G INDEXC
;
INDEXZ ;
Q
;
ACHSSVRP ; IHS/ITSC/PMF - SELECT AND PRINT AO SPECIAL VENDOR REPORT ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 SET (ACHSFAC,ACHSNMS,ACHSSEQ)=""
SET (ACHSEIN,ACHSDCNT,ACHSPGNO)=0
+4 SET ACHSDATE=$$HTE^XLFDT($HOROLOG)
B1 ;
+1 SET ACHSEIN=$ORDER(^ACHSSVR(ACHSEIN))
+2 IF +ACHSEIN=0
GOTO PRTEND
+3 SET DIC="^AUTTVNDR("
SET DIC(0)=""
SET X=ACHSEIN
SET D="E"
+4 DO IX^DIC
+5 IF +Y<1
USE IO(0)
WRITE "VENDOR LOOKUP ERROR FOR EIN # ",ACHSEIN
USE IO
GOTO B1
+6 SET ACHSEINP=+Y
+7 IF '$DATA(^ACHSSVR(ACHSEIN,"N"))
DO INDEX
+8 DO FAX
DO PGHDR
+9 SET ACHSFAC=""
B2 ;
+1 SET ACHSFAC=$ORDER(^ACHSSVR(ACHSEIN,"N",ACHSFAC))
+2 IF +ACHSFAC=0
GOTO B1
+3 SET ACHSNMS=""
B3 ;
+1 SET ACHSNMS=$ORDER(^ACHSSVR(ACHSEIN,"N",ACHSFAC,ACHSNMS))
+2 IF ACHSNMS=""
GOTO B2
+3 SET ACHSSEQ=""
B4 ;
+1 SET ACHSSEQ=$ORDER(^ACHSSVR(ACHSEIN,"N",ACHSFAC,ACHSNMS,ACHSSEQ))
+2 IF +ACHSSEQ=0
GOTO B3
+3 SET ACHSX=$GET(^ACHSSVR(ACHSEIN,ACHSFAC,ACHSSEQ))
+4 KILL DIC
+5 SET DIC="^AUTTLOC("
SET D="C"
SET DIC(0)=""
SET X=ACHSFAC
+6 DO IX^DIC
+7 IF +Y<1
USE IO(0)
WRITE "INVALID FACILITY CODE"
SET ACHSFACN="UNKNOWN FAC CODE"
USE IO
GOTO B5
+8 SET ACHSFACN=$EXTRACT($PIECE($GET(^DIC(4,+Y,0)),U),1,12)
B5 ;
+1 IF $Y>55
DO PGHDR
+2 SET X=ACHSX
+3 WRITE ACHSFACN,?14,$EXTRACT($EXTRACT(X,103,122),1,16),?32,$EXTRACT(X,4,4),"-",$EXTRACT(X,5,7),"-",$EXTRACT(X,8,12),?45,$EXTRACT(X,13,14),"-",$EXTRACT(X,67,67),?51,$EXTRACT(X,34,39),?59
+4 SET ACHSDCNT=ACHSDCNT+1
+5 WRITE $EXTRACT(X,63,64),"/",$EXTRACT(X,65,66),"/",$EXTRACT(X,61,62),?70
+6 SET V=$EXTRACT(X,69,76)/100
+7 WRITE $JUSTIFY(V,9,2),!?14,"TRIBE-CD=",$EXTRACT(X,151,153)," COMM-CD=",$EXTRACT(X,154,160),!
+8 IF $EXTRACT(X,119,119)=" "!($EXTRACT(X,119,119)="")
WRITE !
GOTO B4
+9 WRITE ?14,"<",$EXTRACT(X,119,134),">",!
+10 IF $EXTRACT(X,135,136)=" "
WRITE !!
GOTO B4
+11 WRITE ?14,"<",$EXTRACT(X,135,150),">",!!
+12 GOTO B4
+13 ;
PRTEND ; Print totals.
+1 USE ACHSPTR
+2 WRITE !,$$REPEAT^XLFSTR("-",70),!!?10,"TOTAL DOCUMENTS LISTED = ",ACHSDCNT
ZEND ;
+1 IF $DATA(IO)
IF IO
DO ^%ZISC
ZENDA ;
+1 KILL X,Y,ACHSEIN
+2 QUIT
+3 ;
PGHDR ;
+1 USE ACHSPTR
+2 SET ACHSPGNO=ACHSPGNO+1
+3 WRITE @IOF,$$C^XBFUNC("CHS AUTHORIZATIONS FROM "_$$LOC^ACHS_" FACILITIES",80)
+4 WRITE !,$$C^XBFUNC("FOR "_$PIECE($GET(^AUTTVNDR(ACHSEINP,0)),U),80)
+5 SET Z=^ACHSSVR(ACHSEIN,0)
SET A=$PIECE(Z,U,1)
SET A=$EXTRACT(A,3,4)_"/"_$EXTRACT(A,5,6)_"/"_$EXTRACT(A,1,2)
SET B=$PIECE(Z,U,2)
SET B=$EXTRACT(B,3,4)_"/"_$EXTRACT(B,5,6)_"/"_$EXTRACT(B,1,2)
+6 WRITE !,$$C^XBFUNC("FOR AUTHORIZATIONS ISSUED BETWEEN "_A_" AND "_B,80)
+7 WRITE !,ACHSDATE,?70,"PAGE ",ACHSPGNO,!!!,$$REPEAT^XLFSTR("-",80),!,"LOCATION",?14,"PATIENT NAME",?32,"DOCUMENT #",?45,"TYPE",?51,"IHS #",?59,"AUTH DTE",?70,"$$ AMOUNT",!,$$REPEAT^XLFSTR("-",80),!
+8 QUIT
+9 ;
FAX ; Print FAX cover sheet for vendor.
+1 USE ACHSPTR
+2 WRITE @IOF
+3 FOR I=1:1:5
WRITE !
+4 WRITE $$C^XBFUNC("INDIAN HEALTH SERVICE",80)
+5 WRITE !,$$C^XBFUNC($$LOC^ACHS,80)
+6 WRITE !,$$C^XBFUNC($PIECE(^AUTTLOC(DUZ(2),0),U,12),80)
+7 SET X=$PIECE(^AUTTLOC(DUZ(2),0),U,13)
SET Y=$PIECE(^AUTTLOC(DUZ(2),0),U,14)
SET Z=$PIECE(^DIC(5,+Y,0),U,2)
+8 WRITE !,$$C^XBFUNC(X_", "_Z_" "_$PIECE(^AUTTLOC(DUZ(2),0),U,15),80)
+9 WRITE !!!!!!?10,"DATE: ",$$FMTE^XLFDT(DT)
+10 WRITE !!!!?10,"DELIVER TO:",?25,$EXTRACT($PIECE(^AUTTVNDR(ACHSEINP,0),U,1),1,30)
+11 WRITE !?25,$PIECE(^AUTTVNDR(ACHSEINP,13),U,1)
+12 WRITE !?25,$PIECE(^AUTTVNDR(ACHSEINP,13),U,2)," "
+13 SET Y=$PIECE(^AUTTVNDR(ACHSEINP,13),U,3)
SET Z=$PIECE(^DIC(5,+Y,0),U,2)
+14 WRITE Z," ",$PIECE(^AUTTVNDR(ACHSEINP,13),U,4)
+15 WRITE !!!!?10,"FAX #: ",?25,$PIECE(^AUTTVNDR(ACHSEINP,11),U,14)
+16 WRITE !!!!!!!?10,"FROM: ",?25,"Contract Health Services"
+17 WRITE !?25,$EXTRACT($$LOC^ACHS,1,30)
+18 WRITE !!!!!!?10,"SUBJECT: ",?25,"CHS PURCHASE ORDERS"
+19 WRITE !!
+20 QUIT
+21 ;
INDEX ; Create print index for ^ACHSSVR & Begin & End date.
+1 SET ACHSI=""
SET ACHSJ=1
SET ACHSK=""
+2 IF '$DATA(^ACHSSVR(ACHSEIN,0))
SET ^ACHSSVR(ACHSEIN,0)="999999^0"
INDEXB ;
+1 SET ACHSJ=$ORDER(^ACHSSVR(ACHSEIN,ACHSJ))
+2 IF ACHSJ=""!(+ACHSJ=0)
GOTO INDEXZ
INDEXC ;
+1 ;BEGIN Y2K BLOCK
+2 SET ACHSK=$ORDER(^ACHSSVR(ACHSEIN,ACHSJ,ACHSK))
+3 IF ACHSK=""!(+ACHSK=0)
GOTO INDEXB
+4 SET ACHSX=$GET(^ACHSSVR(ACHSEIN,ACHSJ,ACHSK))
+5 SET ACHSPNAM=$EXTRACT(ACHSX,103,118)
+6 IF ACHSPNAM=""
SET ACHSPNAM=" "
+7 SET ^ACHSSVR(ACHSEIN,"N",ACHSJ,ACHSPNAM,ACHSK)=""
SET ACHSADT=$EXTRACT(ACHSX,61,66)
+8 SET ACHSADT=$SELECT($EXTRACT(ACHSADT,1,2)<84:20000000,1:19000000)+ACHSADT
+9 ;XXX-0999-200030
SET X=$PIECE($GET(^ACHSSVR(ACHSEIN,0)),U)
+10 SET X=$SELECT($EXTRACT(X,1,2)<84:20000000,1:19000000)+X
+11 IF ACHSADT<X
SET $PIECE(^ACHSSVR(ACHSEIN,0),U)=$EXTRACT(ACHSADT,3,8)
+12 SET X=$SELECT($EXTRACT(X,1,2)<84:20000000,1:19000000)+X
+13 ;
IF ACHSADT>X
SET $PIECE(^ACHSSVR(ACHSEIN,0),U,2)=$EXTRACT(ACHSADT,3,8)
+14 ;END Y2K BLOCK
+15 GOTO INDEXC
+16 ;
INDEXZ ;
+1 QUIT
+2 ;
