ABSPOS2.m

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