ABSPOS35 ; IHS/FCS/DRS - survey pharmacy volume ;
;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
Q
MAIN ;EP - option: ABSP VOLUME SURVEY
W !,"Survey of pharmacy volume",!
N RANGE S RANGE=$$DTR^ABSPOSU1 Q:RANGE<1
D ^%ZIS
D VOLUME($P(RANGE,U),$P(RANGE,U,2))
D ^%ZISC
Q
VOLTEST N X1,X2,X,%H S X1=DT,X2=-90 D C^%DTC D VOLUME(X,DT) Q
VOLUME(STARTDT,THRUDT) ;EP - survey daily volume (via AL and AJ indexes)
; Build ^TMP($J,index,date)=how many
; ^TMP($J,index)=total
K ^TMP($J)
N INDEX,RXI,RXR,WEEKDAY,I,X,DATE,NDAYS,COUNT,WKTOTAL
N RPTDATE S RPTDATE=$$NOWEXT^ABSPOSU1
I '$D(THRUDT) S THRUDT=DT
N YEAR S YEAR=$$YEAR(STARTDT) D HEADING
S DATE=STARTDT,WKTOTAL=0,NDAYS=0
F D Q:DATE>THRUDT
. F INDEX="AL","AJ" D
. . S COUNT=$$COUNT(DATE,INDEX)
. . S ^TMP($J,INDEX,DATE)=COUNT
. . S ^TMP($J,INDEX)=$G(^TMP($J,INDEX))+COUNT
. . S WKTOTAL=WKTOTAL+COUNT
. . I INDEX="AL" D
. . . I $$WKDAY(DATE)=0 W $$MMMDD(DATE)
. . . W ?$$WKDAY(DATE)+1*8,$J(COUNT,5)
. . . I $$WKDAY(DATE)=6 W ?70,$J(WKTOTAL,6),! S WKTOTAL=0
. . . I $$EOPQ^ABSPOSU8(2,,"D HEADING^"_$T(+0)) S DATE=9999999
. S NDAYS=NDAYS+1
. S DATE=$$NEXTDAY(DATE) Q:DATE>THRUDT
. I $$YEAR(DATE)'=YEAR D
. . S YEAR=$$YEAR(DATE)
. . D HEADING
W:$X>0 !
D EOPQ^ABSPOSU8(4,,"D HEADING^"_$T(+0))
W "INDEX",?10,"Total",?20,"Average",!
F INDEX="AL","AJ" D
. W INDEX,?10,^TMP($J,INDEX)
. W ?20,$J(^TMP($J,INDEX)/NDAYS,6,1),!
D ENDRPT^ABSPOSU5()
Q
HEADING ;
W @IOF
W "Survey of Pharmacy Volume (",$T(+0),")",?60,RPTDATE,!
W "For " D W !
. N Y S Y=$P(RANGE,U) X ^DD("DD") W Y
. W " through "
. S Y=$P(RANGE,U,2) X ^DD("DD") W Y
. W !
W !,YEAR
F I=0:1:6 W ?I+1*8," ",$P("MON,TUE,WED,THU,FRI,SAT,SUN",",",I+1)
W ?70,"WK. TOTAL",!
Q
COUNT(DATE,INDEX) ;
N C,D,RXI,RXR S C=0
S D=DATE F D S D=$O(^PSRX(INDEX,D)) Q:D="" Q:D\1'=DATE
. S RXI="" F S RXI=$O(^PSRX(INDEX,D,RXI)) Q:RXI="" D
. . S RXR="" F S RXR=$O(^PSRX(INDEX,D,RXI,RXR)) Q:RXR="" D
. . . S C=C+1
Q C
WKDAY(X) ; given X = Fileman date return 0 = Monday, 1 = Tuesday, etc.
Q $$DOLLARH(X)+3#7
DOLLARH(X) ; given X = Fileman date, return $H date
N %H,%T,%Y D H^%DTC Q %H
NEXTDAY(X1) ; given X = Fileman date, return next day's Fileman date
N X2 S X2=1 N X,%H D C^%DTC Q X
YEAR(Y) X ^DD("DD") Q $P($P(Y,"@"),",",2)
MMMDD(Y) X ^DD("DD") Q $P(Y,",")
ABSPOS35 ; IHS/FCS/DRS - survey pharmacy volume ;
+1 ;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
+2 QUIT
MAIN ;EP - option: ABSP VOLUME SURVEY
+1 WRITE !,"Survey of pharmacy volume",!
+2 NEW RANGE
SET RANGE=$$DTR^ABSPOSU1
IF RANGE<1
QUIT
+3 DO ^%ZIS
+4 DO VOLUME($PIECE(RANGE,U),$PIECE(RANGE,U,2))
+5 DO ^%ZISC
+6 QUIT
VOLTEST NEW X1,X2,X,%H
SET X1=DT
SET X2=-90
DO C^%DTC
DO VOLUME(X,DT)
QUIT
VOLUME(STARTDT,THRUDT) ;EP - survey daily volume (via AL and AJ indexes)
+1 ; Build ^TMP($J,index,date)=how many
+2 ; ^TMP($J,index)=total
+3 KILL ^TMP($JOB)
+4 NEW INDEX,RXI,RXR,WEEKDAY,I,X,DATE,NDAYS,COUNT,WKTOTAL
+5 NEW RPTDATE
SET RPTDATE=$$NOWEXT^ABSPOSU1
+6 IF '$DATA(THRUDT)
SET THRUDT=DT
+7 NEW YEAR
SET YEAR=$$YEAR(STARTDT)
DO HEADING
+8 SET DATE=STARTDT
SET WKTOTAL=0
SET NDAYS=0
+9 FOR
Begin DoDot:1
+10 FOR INDEX="AL","AJ"
Begin DoDot:2
+11 SET COUNT=$$COUNT(DATE,INDEX)
+12 SET ^TMP($JOB,INDEX,DATE)=COUNT
+13 SET ^TMP($JOB,INDEX)=$GET(^TMP($JOB,INDEX))+COUNT
+14 SET WKTOTAL=WKTOTAL+COUNT
+15 IF INDEX="AL"
Begin DoDot:3
+16 IF $$WKDAY(DATE)=0
WRITE $$MMMDD(DATE)
+17 WRITE ?$$WKDAY(DATE)+1*8,$JUSTIFY(COUNT,5)
+18 IF $$WKDAY(DATE)=6
WRITE ?70,$JUSTIFY(WKTOTAL,6),!
SET WKTOTAL=0
+19 IF $$EOPQ^ABSPOSU8(2,,"D HEADING^"_$TEXT(+0))
SET DATE=9999999
End DoDot:3
End DoDot:2
+20 SET NDAYS=NDAYS+1
+21 SET DATE=$$NEXTDAY(DATE)
IF DATE>THRUDT
QUIT
+22 IF $$YEAR(DATE)'=YEAR
Begin DoDot:2
+23 SET YEAR=$$YEAR(DATE)
+24 DO HEADING
End DoDot:2
End DoDot:1
IF DATE>THRUDT
QUIT
+25 IF $X>0
WRITE !
+26 DO EOPQ^ABSPOSU8(4,,"D HEADING^"_$TEXT(+0))
+27 WRITE "INDEX",?10,"Total",?20,"Average",!
+28 FOR INDEX="AL","AJ"
Begin DoDot:1
+29 WRITE INDEX,?10,^TMP($JOB,INDEX)
+30 WRITE ?20,$JUSTIFY(^TMP($JOB,INDEX)/NDAYS,6,1),!
End DoDot:1
+31 DO ENDRPT^ABSPOSU5()
+32 QUIT
HEADING ;
+1 WRITE @IOF
+2 WRITE "Survey of Pharmacy Volume (",$TEXT(+0),")",?60,RPTDATE,!
+3 WRITE "For "
Begin DoDot:1
+4 NEW Y
SET Y=$PIECE(RANGE,U)
XECUTE ^DD("DD")
WRITE Y
+5 WRITE " through "
+6 SET Y=$PIECE(RANGE,U,2)
XECUTE ^DD("DD")
WRITE Y
+7 WRITE !
End DoDot:1
WRITE !
+8 WRITE !,YEAR
+9 FOR I=0:1:6
WRITE ?I+1*8," ",$PIECE("MON,TUE,WED,THU,FRI,SAT,SUN",",",I+1)
+10 WRITE ?70,"WK. TOTAL",!
+11 QUIT
COUNT(DATE,INDEX) ;
+1 NEW C,D,RXI,RXR
SET C=0
+2 SET D=DATE
FOR
Begin DoDot:1
+3 SET RXI=""
FOR
SET RXI=$ORDER(^PSRX(INDEX,D,RXI))
IF RXI=""
QUIT
Begin DoDot:2
+4 SET RXR=""
FOR
SET RXR=$ORDER(^PSRX(INDEX,D,RXI,RXR))
IF RXR=""
QUIT
Begin DoDot:3
+5 SET C=C+1
End DoDot:3
End DoDot:2
End DoDot:1
SET D=$ORDER(^PSRX(INDEX,D))
IF D=""
QUIT
IF D\1'=DATE
QUIT
+6 QUIT C
WKDAY(X) ; given X = Fileman date return 0 = Monday, 1 = Tuesday, etc.
+1 QUIT $$DOLLARH(X)+3#7
DOLLARH(X) ; given X = Fileman date, return $H date
+1 NEW %H,%T,%Y
DO H^%DTC
QUIT %H
NEXTDAY(X1) ; given X = Fileman date, return next day's Fileman date
+1 NEW X2
SET X2=1
NEW X,%H
DO C^%DTC
QUIT X
YEAR(Y) XECUTE ^DD("DD")
QUIT $PIECE($PIECE(Y,"@"),",",2)
MMMDD(Y) XECUTE ^DD("DD")
QUIT $PIECE(Y,",")
