ABSPOS2 ; IHS/FCS/DRS - POS manager's ScreenMan ;
;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
;
; SEE code at tag HELP - is this an entry point we can use?
;
; ALL writes of screen lines should be done as follows:
; IF $$VISIBLE(line) DO WRITE^VALM10(line)
; Then NODISPLY can be set so that $$VISIBLE always returns FALSE
;
; option ABSP MANAGER SCREEN
D EN^ABSPOS2() Q
;; ;
ERROR D FULL^VALM1 Q ; what's a ^%ZOSF way to ZQUIT ?
EN() ;EP - main entry point for list template ABSP STATISTICS AND MANAGEMENT
;S $ZT="ERROR^"_$T(+0) ; you lose the stack printout when you do this!
N BASE,CURR,DISP,AVG,DIFF,CHG
; BASE(*) = base values, from when zeroed things out
; CURR(*) = current values, from most recent read
; DIFF(*) = differences
; CHG(*) = changed value to print, if any
N LOCK S LOCK=1 ; should we lock stats when we fetch?
;D MYPARAMS
;D FETCHES(0) ; fetch stats into BASE() and CURR() both
;D DIFF
;S ^TMP("ABSPOS2",$J,"FREQ")=30 ;D UPDATE(-1)
I $P($G(^ABSPECX("S",1,0)),U,2)="" D
.N %,%H,%I,X D NOW^%DTC S $P(^ABSPECX("S",1,0),U,2)=%
D EN^VALM("ABSP STATISTICS AND MANAGEMENT")
Q
INIT ; -- init variables and list array
N NODISPLY S NODISPLY=1
D MYPARAMS
D CLEAN^VALM10
S VALMCNT=0 ; 0 lines so far
D LABELS^ABSPOS2C
D HDR
D FETCHES(1) ; set up CURR
D DIFF ; compute DIFF = differences and changed ones go into CHG
D VALUES^ABSPOS2B ; displays whatever's in CHG() and kills it off
Q
FETCHES(B) ;EP - from ABSPOS2A
; B = 0 to fetch into BASE(...) array, 1 for CURR(...) array
N DST S DST=$S(B=1:"CURR",B=0:"BASE")
S ^TMP("ABSPOS2",$J,"$H",DST)=$H
D FETCH58(DST_"(""COMM"")")
D FETSTAT(DST_"(""STAT"")")
D FETPKTQ(DST_"(""PKTQ"")")
I B=0 D ; if setting BASE values, copy them into CURR
.M CURR=BASE ; copy them into CURR
.S ^TMP("ABSPOS2",$J,"$H","BASE")=$H
Q
DIFF ;EP - from ABSPOS2A
K CHG ; compute DIFF=CURR-BASE differences; set CHG for any changed
N A,B,X S A=""
F S A=$O(CURR(A)) Q:A="" S B="" F S B=$O(CURR(A,B)) Q:B="" D
.S X=CURR(A,B)-$G(BASE(A,B))
.I X'=$G(DIFF(A,B)) S (DIFF(A,B),CHG(A,B))=X
Q
UPD1 ; one update cycle
N A,B,T
D FETCHES(1) ; fetch into CURR array
D DIFF ; compute differences
D VALUES^ABSPOS2B ; compute values and display if changed
Q
HDT(X) ; first convert fileman date-time to $H format, then $$H it
N %H,%T,%Y D H^%DTC S X=$P(X,".",2)
Q $$H(%H_","_($E(X,1,2)*3600+($E(X,3,4)*60)+$E(X,5,6)))
H(H) S:'$D(H) H=$H Q $P(H,",")-58000*86400+$P(H,",",2) ; $$H seconds
FETCH58(DST) ; send DST = closed root of the destination
K @DST
N FN,DIC,DR,DA,DIQ,TMP ; note that DA=1 is hardcoded
S @DST@("$$H")=$$H
S (FN,DIC)=9002313.58,DR="1:10000",DIQ="TMP(",DA=1
I LOCK L +^ABSP(FN):300
D EN^DIQ1
I LOCK L -^ABSP(FN)
M @DST=TMP(FN,1)
S @DST@(2)=$P(^ABSPECX("S",1,0),U,2) ; overwrite w/internal form
S @DST@(2)=$$HDT(@DST@(2))
Q
FETSTAT(DEST) ;EP - from ABSPOSIW
; send DEST = closed root of the destination
K @DEST
S @DEST@("$$H")=$$H
I LOCK LOCK +^ABSPT
N Q,N,A F Q=0:10:90,19,31,51 D
.S A="" F N=0:1 S A=$O(^ABSPT("AD",Q,A)) Q:A=""
. I Q#10 S @DEST@(Q\10*10)=@DEST@(Q\10*10)+N
. E S @DEST@(Q)=N ; relies on multiples of 10 coming first!
I LOCK LOCK -^ABSPT
Q
FETPKTQ(DEST) ;EP - from ABSPOSIW,ABSPOSRB
; send DEST = closed root of the destination
; send LOCK = true if you want to lock all the queues (for exact count)
; ^ABSPECX("POS",psetien,"C",n) and "R"
; @DEST@("C",PSetIEN) = packets waiting to send
; @DEST@("C")=total of all the "C" counts
; @DEST@("R",PSetIEN) = packets received awaiting receive processing
; @DEST@("R")=total
K @DEST
S @DEST@("$$H")=$$H,(@DEST@("C"),@DEST@("R"))=0
; Would need to do similarly for each PSetIEN value too INCOMPLETE
I LOCK LOCK +^ABSPECX("POS")
N A,B,C,N,P,X
S A="" F S A=$O(^ABSPECX("POS",A)) Q:A="" D
.F B="C","R" D
..S C="" F N=0:1 S C=$O(^ABSPECX("POS",A,B,C)) Q:C=""
..S @DEST@(B,A)=N
..S @DEST@(B)=$G(@DEST@(B))+N
I LOCK LOCK -^ABSPECX("POS")
Q
MYPARAMS ;
Q
UPDFREQ() ;I DUZ=9598 Q 5 ; I get it every 5 seconds
Q 15 ; every fifteen seconds is the usual case
;
CLEARAT() ;
S Y=$P(^ABSPECX("S",1,0),U,2) X ^DD("DD") Q Y
HDR ; -- header code
S VALMHDR(1)="Communications statistics last cleared on "_$$CLEARAT
S XQORM("B")="CU" ; the default is Update Continuously
S XQORM("B")="U1" ; but we'd like to do U1 continuously from top lvl
Q
;
UPD ;EP - From ABSPOS2A ; Protocol ABSP P2 UPDATE
D UPDATE(1) S VALMBCK="",XQORM("B")="U1" Q ; ABSB RXE POS P2 UPDATE
CONTUPD ; Protocol ABSP P2 CONTINUOUS
W !!!!! D UPDATE(-1) S VALMBCK="" Q ; ABSB RXE POS P2 CONTINUOUS
UPDATE(COUNTER) ; with COUNTER = a count down
N STOP F D Q:$G(STOP)
.D UPD1
.S COUNTER=COUNTER-1 I 'COUNTER S STOP=1 Q
.I '$G(NODISPLY) D
..D MSG^VALM10("In continuous update mode: press Q to Quit")
..;I $D(^TMP("XGKEY",$J)) possible interference?
..N X S X=$$READ^XGKB(1,$$UPDFREQ) D MSG^VALM10(" ")
..;N X R X#1:^TMP("ABSPOS2",$J,"FREQ") D MSG^VALM10(" ")
..;I X]"","Qq^^"[X S STOP=1
..I '$G(DTOUT),X]"","Qq^^"[X S STOP=1
..N Y F R Y:0 Q:'$T ; clean out typeahead (like mistaken arrow keys)
..; But if timed out, keep looping and updating
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
D FULL^VALM1
Q
;
EXPND ; -- expand code
Q
ABSPOS2 ; IHS/FCS/DRS - POS manager's ScreenMan ;
+1 ;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
+2 ;
+3 ; SEE code at tag HELP - is this an entry point we can use?
+4 ;
+5 ; ALL writes of screen lines should be done as follows:
+6 ; IF $$VISIBLE(line) DO WRITE^VALM10(line)
+7 ; Then NODISPLY can be set so that $$VISIBLE always returns FALSE
+8 ;
+9 ; option ABSP MANAGER SCREEN
+10 DO EN^ABSPOS2()
QUIT
+11 ;; ;
ERROR ; what's a ^%ZOSF way to ZQUIT ?
DO FULL^VALM1
QUIT
EN() ;EP - main entry point for list template ABSP STATISTICS AND MANAGEMENT
+1 ;S $ZT="ERROR^"_$T(+0) ; you lose the stack printout when you do this!
+2 NEW BASE,CURR,DISP,AVG,DIFF,CHG
+3 ; BASE(*) = base values, from when zeroed things out
+4 ; CURR(*) = current values, from most recent read
+5 ; DIFF(*) = differences
+6 ; CHG(*) = changed value to print, if any
+7 ; should we lock stats when we fetch?
NEW LOCK
SET LOCK=1
+8 ;D MYPARAMS
+9 ;D FETCHES(0) ; fetch stats into BASE() and CURR() both
+10 ;D DIFF
+11 ;S ^TMP("ABSPOS2",$J,"FREQ")=30 ;D UPDATE(-1)
+12 IF $PIECE($GET(^ABSPECX("S",1,0)),U,2)=""
Begin DoDot:1
+13 NEW %,%H,%I,X
DO NOW^%DTC
SET $PIECE(^ABSPECX("S",1,0),U,2)=%
End DoDot:1
+14 DO EN^VALM("ABSP STATISTICS AND MANAGEMENT")
+15 QUIT
INIT ; -- init variables and list array
+1 NEW NODISPLY
SET NODISPLY=1
+2 DO MYPARAMS
+3 DO CLEAN^VALM10
+4 ; 0 lines so far
SET VALMCNT=0
+5 DO LABELS^ABSPOS2C
+6 DO HDR
+7 ; set up CURR
DO FETCHES(1)
+8 ; compute DIFF = differences and changed ones go into CHG
DO DIFF
+9 ; displays whatever's in CHG() and kills it off
DO VALUES^ABSPOS2B
+10 QUIT
FETCHES(B) ;EP - from ABSPOS2A
+1 ; B = 0 to fetch into BASE(...) array, 1 for CURR(...) array
+2 NEW DST
SET DST=$SELECT(B=1:"CURR",B=0:"BASE")
+3 SET ^TMP("ABSPOS2",$JOB,"$H",DST)=$HOROLOG
+4 DO FETCH58(DST_"(""COMM"")")
+5 DO FETSTAT(DST_"(""STAT"")")
+6 DO FETPKTQ(DST_"(""PKTQ"")")
+7 ; if setting BASE values, copy them into CURR
IF B=0
Begin DoDot:1
+8 ; copy them into CURR
MERGE CURR=BASE
+9 SET ^TMP("ABSPOS2",$JOB,"$H","BASE")=$HOROLOG
End DoDot:1
+10 QUIT
DIFF ;EP - from ABSPOS2A
+1 ; compute DIFF=CURR-BASE differences; set CHG for any changed
KILL CHG
+2 NEW A,B,X
SET A=""
+3 FOR
SET A=$ORDER(CURR(A))
IF A=""
QUIT
SET B=""
FOR
SET B=$ORDER(CURR(A,B))
IF B=""
QUIT
Begin DoDot:1
+4 SET X=CURR(A,B)-$GET(BASE(A,B))
+5 IF X'=$GET(DIFF(A,B))
SET (DIFF(A,B),CHG(A,B))=X
End DoDot:1
+6 QUIT
UPD1 ; one update cycle
+1 NEW A,B,T
+2 ; fetch into CURR array
DO FETCHES(1)
+3 ; compute differences
DO DIFF
+4 ; compute values and display if changed
DO VALUES^ABSPOS2B
+5 QUIT
HDT(X) ; first convert fileman date-time to $H format, then $$H it
+1 NEW %H,%T,%Y
DO H^%DTC
SET X=$PIECE(X,".",2)
+2 QUIT $$H(%H_","_($EXTRACT(X,1,2)*3600+($EXTRACT(X,3,4)*60)+$EXTRACT(X,5,6)))
H(H) ; $$H seconds
IF '$DATA(H)
SET H=$HOROLOG
QUIT $PIECE(H,",")-58000*86400+$PIECE(H,",",2)
FETCH58(DST) ; send DST = closed root of the destination
+1 KILL @DST
+2 ; note that DA=1 is hardcoded
NEW FN,DIC,DR,DA,DIQ,TMP
+3 SET @DST@("$$H")=$$H
+4 SET (FN,DIC)=9002313.58
SET DR="1:10000"
SET DIQ="TMP("
SET DA=1
+5 IF LOCK
LOCK +^ABSP(FN):300
+6 DO EN^DIQ1
+7 IF LOCK
LOCK -^ABSP(FN)
+8 MERGE @DST=TMP(FN,1)
+9 ; overwrite w/internal form
SET @DST@(2)=$PIECE(^ABSPECX("S",1,0),U,2)
+10 SET @DST@(2)=$$HDT(@DST@(2))
+11 QUIT
FETSTAT(DEST) ;EP - from ABSPOSIW
+1 ; send DEST = closed root of the destination
+2 KILL @DEST
+3 SET @DEST@("$$H")=$$H
+4 IF LOCK
LOCK +^ABSPT
+5 NEW Q,N,A
FOR Q=0:10:90,19,31,51
Begin DoDot:1
+6 SET A=""
FOR N=0:1
SET A=$ORDER(^ABSPT("AD",Q,A))
IF A=""
QUIT
+7 IF Q#10
SET @DEST@(Q\10*10)=@DEST@(Q\10*10)+N
+8 ; relies on multiples of 10 coming first!
IF '$TEST
SET @DEST@(Q)=N
End DoDot:1
+9 IF LOCK
LOCK -^ABSPT
+10 QUIT
FETPKTQ(DEST) ;EP - from ABSPOSIW,ABSPOSRB
+1 ; send DEST = closed root of the destination
+2 ; send LOCK = true if you want to lock all the queues (for exact count)
+3 ; ^ABSPECX("POS",psetien,"C",n) and "R"
+4 ; @DEST@("C",PSetIEN) = packets waiting to send
+5 ; @DEST@("C")=total of all the "C" counts
+6 ; @DEST@("R",PSetIEN) = packets received awaiting receive processing
+7 ; @DEST@("R")=total
+8 KILL @DEST
+9 SET @DEST@("$$H")=$$H
SET (@DEST@("C"),@DEST@("R"))=0
+10 ; Would need to do similarly for each PSetIEN value too INCOMPLETE
+11 IF LOCK
LOCK +^ABSPECX("POS")
+12 NEW A,B,C,N,P,X
+13 SET A=""
FOR
SET A=$ORDER(^ABSPECX("POS",A))
IF A=""
QUIT
Begin DoDot:1
+14 FOR B="C","R"
Begin DoDot:2
+15 SET C=""
FOR N=0:1
SET C=$ORDER(^ABSPECX("POS",A,B,C))
IF C=""
QUIT
+16 SET @DEST@(B,A)=N
+17 SET @DEST@(B)=$GET(@DEST@(B))+N
End DoDot:2
End DoDot:1
+18 IF LOCK
LOCK -^ABSPECX("POS")
+19 QUIT
MYPARAMS ;
+1 QUIT
UPDFREQ() ;I DUZ=9598 Q 5 ; I get it every 5 seconds
+1 ; every fifteen seconds is the usual case
QUIT 15
+2 ;
CLEARAT() ;
+1 SET Y=$PIECE(^ABSPECX("S",1,0),U,2)
XECUTE ^DD("DD")
QUIT Y
HDR ; -- header code
+1 SET VALMHDR(1)="Communications statistics last cleared on "_$$CLEARAT
+2 ; the default is Update Continuously
SET XQORM("B")="CU"
+3 ; but we'd like to do U1 continuously from top lvl
SET XQORM("B")="U1"
+4 QUIT
+5 ;
UPD ;EP - From ABSPOS2A ; Protocol ABSP P2 UPDATE
+1 ; ABSB RXE POS P2 UPDATE
DO UPDATE(1)
SET VALMBCK=""
SET XQORM("B")="U1"
QUIT
CONTUPD ; Protocol ABSP P2 CONTINUOUS
+1 ; ABSB RXE POS P2 CONTINUOUS
WRITE !!!!!
DO UPDATE(-1)
SET VALMBCK=""
QUIT
UPDATE(COUNTER) ; with COUNTER = a count down
+1 NEW STOP
FOR
Begin DoDot:1
+2 DO UPD1
+3 SET COUNTER=COUNTER-1
IF 'COUNTER
SET STOP=1
QUIT
+4 IF '$GET(NODISPLY)
Begin DoDot:2
+5 DO MSG^VALM10("In continuous update mode: press Q to Quit")
+6 ;I $D(^TMP("XGKEY",$J)) possible interference?
+7 NEW X
SET X=$$READ^XGKB(1,$$UPDFREQ)
DO MSG^VALM10(" ")
+8 ;N X R X#1:^TMP("ABSPOS2",$J,"FREQ") D MSG^VALM10(" ")
+9 ;I X]"","Qq^^"[X S STOP=1
+10 IF '$GET(DTOUT)
IF X]""
IF "Qq^^"[X
SET STOP=1
+11 ; clean out typeahead (like mistaken arrow keys)
NEW Y
FOR
READ Y:0
IF '$TEST
QUIT
+12 ; But if timed out, keep looping and updating
End DoDot:2
End DoDot:1
IF $GET(STOP)
QUIT
+13 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 DO FULL^VALM1
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
