ACHSSVRQ ; 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
;
A2 ;
I '$D(^ACHSAOP(DUZ(2),21)) W *7,!,"No Special Vendors have been identified",!,"in the CHS AREA OFFICE PARAMETERS file." G ZEND
W !
S DIC="^ACHSAOP("_DUZ(2)_",21,",DIC(0)="QAZEM"
D ^DIC
G ZEND:$D(DUOUT)!($D(DTOUT))!(+Y<1)
S ACHSEINP=$P(Y,U,2),ACHSEIN=$P(^AUTTVNDR(ACHSEINP,11),U,13)
B0 ;
G NOREPORT:'$D(^ACHSSVR(ACHSEIN))
B1A ;
S ACHSFAX=$$DIR^XBDIR("Y","Do you want a FAX Cover Sheet Generated for This Vendor (Y/N) ","Y","","","",1)
G A2:$D(DIRUT)!($D(DTOUT))!($D(DUOUT))
B0C ;
S %=$$PB^ACHS
I %=U!$D(DTOUT)!$D(DUOUT) Q
I %="B" D VIEWR^XBLM("PRINT^ACHSSVRQ"),EN^XBVK("VALM") Q
S ACHSIOQ="",%ZIS="PQ"
D ^%ZIS
S ACHSIO=IO
I $D(IO("Q"))=1 S ACHSIOQ=IO("Q")
I ACHSIOQ="" G PRINT
I $D(IO("S"))!($E(IOST)'="P") G B0C
ZTLOAD ;
S ZTRTN="PRINT^ACHSSVRQ",ZTDESC="PRINT SPECIAL AO VENDOR REPORTS",ZTIO=ION
F %="ACHSEIN","ACHSFAX","ACHSEINP" S ZTSAVE(%)=""
D ^%ZTLOAD
K IO("Q")
D HOME^%ZIS
K IOP
D KILL^%ZTLOAD
G A2
;
PRINT ;EP - From TaskMan.
S (ACHSFAC,ACHSNMS,ACHSSEQ)="",(ACHSDCNT,ACHSPGNO)=0
I ACHSFAX=1 D FAX
S ACHSDATE=$$HTE^XLFDT($H)
I '$D(^ACHSSVR(ACHSEIN,"N")) D INDEX
D PGHDR
B2 ;
S ACHSFAC=$O(^ACHSSVR(ACHSEIN,"N",ACHSFAC))
G PRTEND:+ACHSFAC=0
B3 ;
S ACHSNMS=$O(^ACHSSVR(ACHSEIN,"N",ACHSFAC,ACHSNMS))
G B2:ACHSNMS=""
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" H 3 G A2
S ACHSFACN=$E($P($G(^DIC(4,+Y,0)),U),1,12)
I $Y>55 D PGHDR
S X=ACHSX
W ACHSFACN,?14,$E($E(X,103,118),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),!," (",ACHSFAC,")",?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 ; End printing, print totals.
U IO
W !,$$REPEAT^XLFSTR("-",70),!!?10,"TOTAL DOCUMENTS LISTED = ",ACHSDCNT
Q:ACHSIOQ'=""
U IO(0)
S Y=$$DIR^XBDIR("Y","Do You want to Select Another Vendor ","N","","","",1)
G ZEND:+Y=0,A2
;
ZEND ; Close device, kill vars, quit.
I $$DIR^XBDIR("E","Press RETURN...")
I $G(IO) D ^%ZISC
K ACHSEIN,ACHSFAX
Q
;
NOREPORT ; No information in ACHSAOP(DUZ(2),"SVR",ACHSEIN
U IO(0)
W !,"No Report available for this Vendor"
S Y=$$DIR^XBDIR("E","Enter <RETURN> to select another Vendor or '^' to Exit")
G A2:Y=1,ZEND:Y=0
PGHDR ; Print report header.
U IO
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 ;EP - Print FAX cover sheet for vendor.
U IO
W @IOF,!!!!!,$$C^XBFUNC("INDIAN HEALTH SERVICE",80),!,$$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 ;EP - Create print index for ^ACHSSVR & begin & end dates.
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)
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,1)=$E(ACHSADT,3,8) ; XXX-0999-200030
S X=$P($G(^ACHSSVR(ACHSEIN,0)),U,2) ; XXX-0999-200030
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) ; XXX-0999-200030
;END Y2K BLOCK
G INDEXC
;
INDEXZ ;
Q
;
ACHSSVRQ ; 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 ;
A2 ;
+1 IF '$DATA(^ACHSAOP(DUZ(2),21))
WRITE *7,!,"No Special Vendors have been identified",!,"in the CHS AREA OFFICE PARAMETERS file."
GOTO ZEND
+2 WRITE !
+3 SET DIC="^ACHSAOP("_DUZ(2)_",21,"
SET DIC(0)="QAZEM"
+4 DO ^DIC
+5 IF $DATA(DUOUT)!($DATA(DTOUT))!(+Y<1)
GOTO ZEND
+6 SET ACHSEINP=$PIECE(Y,U,2)
SET ACHSEIN=$PIECE(^AUTTVNDR(ACHSEINP,11),U,13)
B0 ;
+1 IF '$DATA(^ACHSSVR(ACHSEIN))
GOTO NOREPORT
B1A ;
+1 SET ACHSFAX=$$DIR^XBDIR("Y","Do you want a FAX Cover Sheet Generated for This Vendor (Y/N) ","Y","","","",1)
+2 IF $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))
GOTO A2
B0C ;
+1 SET %=$$PB^ACHS
+2 IF %=U!$DATA(DTOUT)!$DATA(DUOUT)
QUIT
+3 IF %="B"
DO VIEWR^XBLM("PRINT^ACHSSVRQ")
DO EN^XBVK("VALM")
QUIT
+4 SET ACHSIOQ=""
SET %ZIS="PQ"
+5 DO ^%ZIS
+6 SET ACHSIO=IO
+7 IF $DATA(IO("Q"))=1
SET ACHSIOQ=IO("Q")
+8 IF ACHSIOQ=""
GOTO PRINT
+9 IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
GOTO B0C
ZTLOAD ;
+1 SET ZTRTN="PRINT^ACHSSVRQ"
SET ZTDESC="PRINT SPECIAL AO VENDOR REPORTS"
SET ZTIO=ION
+2 FOR %="ACHSEIN","ACHSFAX","ACHSEINP"
SET ZTSAVE(%)=""
+3 DO ^%ZTLOAD
+4 KILL IO("Q")
+5 DO HOME^%ZIS
+6 KILL IOP
+7 DO KILL^%ZTLOAD
+8 GOTO A2
+9 ;
PRINT ;EP - From TaskMan.
+1 SET (ACHSFAC,ACHSNMS,ACHSSEQ)=""
SET (ACHSDCNT,ACHSPGNO)=0
+2 IF ACHSFAX=1
DO FAX
+3 SET ACHSDATE=$$HTE^XLFDT($HOROLOG)
+4 IF '$DATA(^ACHSSVR(ACHSEIN,"N"))
DO INDEX
+5 DO PGHDR
B2 ;
+1 SET ACHSFAC=$ORDER(^ACHSSVR(ACHSEIN,"N",ACHSFAC))
+2 IF +ACHSFAC=0
GOTO PRTEND
B3 ;
+1 SET ACHSNMS=$ORDER(^ACHSSVR(ACHSEIN,"N",ACHSFAC,ACHSNMS))
+2 IF ACHSNMS=""
GOTO B2
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"
HANG 3
GOTO A2
+8 SET ACHSFACN=$EXTRACT($PIECE($GET(^DIC(4,+Y,0)),U),1,12)
+9 IF $Y>55
DO PGHDR
+10 SET X=ACHSX
+11 WRITE ACHSFACN,?14,$EXTRACT($EXTRACT(X,103,118),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
+12 SET ACHSDCNT=ACHSDCNT+1
+13 WRITE $EXTRACT(X,63,64),"/",$EXTRACT(X,65,66),"/",$EXTRACT(X,61,62),?70
+14 SET V=$EXTRACT(X,69,76)/100
+15 WRITE $JUSTIFY(V,9,2),!," (",ACHSFAC,")",?14,"TRIBE-CD=",$EXTRACT(X,151,153)," COMM-CD=",$EXTRACT(X,154,160),!
+16 IF $EXTRACT(X,119,119)=" "!($EXTRACT(X,119,119)="")
WRITE !
GOTO B4
+17 WRITE ?14,"<",$EXTRACT(X,119,134),">",!
+18 IF $EXTRACT(X,135,136)=" "
WRITE !!
GOTO B4
+19 WRITE ?14,"<",$EXTRACT(X,135,150),">",!!
+20 GOTO B4
+21 ;
PRTEND ; End printing, print totals.
+1 USE IO
+2 WRITE !,$$REPEAT^XLFSTR("-",70),!!?10,"TOTAL DOCUMENTS LISTED = ",ACHSDCNT
+3 IF ACHSIOQ'=""
QUIT
+4 USE IO(0)
+5 SET Y=$$DIR^XBDIR("Y","Do You want to Select Another Vendor ","N","","","",1)
+6 IF +Y=0
GOTO ZEND
GOTO A2
+7 ;
ZEND ; Close device, kill vars, quit.
+1 IF $$DIR^XBDIR("E","Press RETURN...")
+2 IF $GET(IO)
DO ^%ZISC
+3 KILL ACHSEIN,ACHSFAX
+4 QUIT
+5 ;
NOREPORT ; No information in ACHSAOP(DUZ(2),"SVR",ACHSEIN
+1 USE IO(0)
+2 WRITE !,"No Report available for this Vendor"
+3 SET Y=$$DIR^XBDIR("E","Enter <RETURN> to select another Vendor or '^' to Exit")
+4 IF Y=1
GOTO A2
IF Y=0
GOTO ZEND
PGHDR ; Print report header.
+1 USE IO
+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 ;EP - Print FAX cover sheet for vendor.
+1 USE IO
+2 WRITE @IOF,!!!!!,$$C^XBFUNC("INDIAN HEALTH SERVICE",80),!,$$C^XBFUNC($$LOC^ACHS,80)
+3 WRITE !,$$C^XBFUNC($PIECE(^AUTTLOC(DUZ(2),0),U,12),80)
+4 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)
+5 WRITE !,$$C^XBFUNC(X_", "_Z_" "_$PIECE(^AUTTLOC(DUZ(2),0),U,15),80)
+6 WRITE !!!!!!?10,"DATE: ",$$FMTE^XLFDT(DT)
+7 WRITE !!!!?10,"DELIVER TO:",?25,$EXTRACT($PIECE(^AUTTVNDR(ACHSEINP,0),U,1),1,30)
+8 WRITE !?25,$PIECE(^AUTTVNDR(ACHSEINP,13),U,1)
+9 WRITE !?25,$PIECE(^AUTTVNDR(ACHSEINP,13),U,2)," "
+10 SET Y=$PIECE(^AUTTVNDR(ACHSEINP,13),U,3)
SET Z=$PIECE(^DIC(5,+Y,0),U,2)
+11 WRITE Z," ",$PIECE(^AUTTVNDR(ACHSEINP,13),U,4)
+12 WRITE !!!!?10,"FAX #: ",?25,$PIECE(^AUTTVNDR(ACHSEINP,11),U,14)
+13 WRITE !!!!!!!?10,"FROM: ",?25,"Contract Health Services"
+14 WRITE !?25,$EXTRACT($$LOC^ACHS,1,30)
+15 WRITE !!!!!!?10,"SUBJECT: ",?25,"CHS PURCHASE ORDERS"
+16 WRITE !!
+17 QUIT
+18 ;
INDEX ;EP - Create print index for ^ACHSSVR & begin & end dates.
+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)
+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 ; XXX-0999-200030
IF ACHSADT<X
SET $PIECE(^ACHSSVR(ACHSEIN,0),U,1)=$EXTRACT(ACHSADT,3,8)
+12 ; XXX-0999-200030
SET X=$PIECE($GET(^ACHSSVR(ACHSEIN,0)),U,2)
+13 SET X=$SELECT($EXTRACT(X,1,2)<84:20000000,1:19000000)+X
+14 ; XXX-0999-200030
IF ACHSADT>X
SET $PIECE(^ACHSSVR(ACHSEIN,0),U,2)=$EXTRACT(ACHSADT,3,8)
+15 ;END Y2K BLOCK
+16 GOTO INDEXC
+17 ;
INDEXZ ;
+1 QUIT
+2 ;
