- PSXYQRY ;BIR/HTW-Dual Sends/Receives the Query ;[ 02/20/99 5:49 PM ]
- ;;2.0;CMOP;**17**;11 Apr 97
- EN I $P($G(^PSX(553,1,"Q")),"^")="S" S PSXSTOP=1 G TST
- D NOW^%DTC S XZ=$P(^PSX(553.1,0),"^",3),INT=$P(^PSX(553,1,0),"^",9) S:$G(INT)'>0 INT=1
- I $G(XZ) S LQRYTM=$P(^PSX(553.1,XZ,0),"^",2),NEXTQRY=$$FMADD^XLFDT(LQRYTM,0,INT,0,0)
- I %>NEXTQRY G EN1
- I %'>NEXTQRY H $$FMDIFF^XLFDT(%,LQRYTM,2)
- EN1 S (PSXCNT,PSXTRYN,RXCNT)=0,QLR=$P($G(^PSX(553,1,0)),"^",8)
- K DD,DO
- S (DA,X)=$P(^PSX(553.1,0),U,3)+1,DIC="^PSX(553.1,",DIC(0)="LZ",DIC("DR")="1////"_%_";4////1",DLAYGO=553.1
- F D FILE^DICN S PSXQRYID=+Y,LOG(1)="QUERY # "_PSXQRYID_" initiated."_$G(PSXQRYA) D LOG^PSXUTL
- I $P($G(^PSX(553,1,"Q")),"^")="S" S PSXSTOP=1 G TST
- K DA,DIC,DUOUT,DTOUT,DLAYGO,X,Y,%,DINUM,PSXPOP,TRY
- S PSXQRY=1 D BID G:$G(PSXQUIT) TST
- D TSOUT^PSXUTL
- S PSXBLK=1,PSXLAST=0
- S PSXTXT="MSH|^~\&|DHCP||"_$S($G(PSXVNDR)>1:"SI BAKER",$G(PSXVNDR)=1:"ELECTROCOM",1:"ELECTROCOM")_"||"_PSXTS_"||QRY|"_PSXQRYID_"|P|2.1|" D XMIT^PSXYSND G:$G(PSXPOP) TST
- S PSXBLK=2,PSXLAST=1 S PSXTXT="QRD|"_PSXTS_"|R|I|"_PSXQRYID_"|||"_QLR_"^ZO|OP|OTH|ALL" D XMIT^PSXYSND G:$G(PSXPOP) TST
- W *EOT,*TERM
- D SLAVE
- TST D FLUSH1^PSXUTL
- S LOG(1)="QUERY # "_$G(PSXQRYID)_" completed."_$G(PSXQRYA) S:$G(PSXSTOP) LOG(2)="DHCP STOPPED QUERY "_$G(PSXQRYID) S:$G(PSXQUIT) LOG(3)="No Response to Bid, DHCP terminated query." D LOG^PSXUTL
- S $P(^PSX(554,1,0),"^",3)=$G(PSXQRYID)
- K PSXHEX,PSXACK,LOG,BLK,BLKA,PSXQRYID,PSXTXT,PSXBLK,%,X,Y,PSXLAST,QLR,MESSID,MSGID,RXCNT,PSXQRY,PSXQRYA,PSXSTOP,PSXPOP,PSXQUIT
- S ZTREQ="@"
- G:$G(^PSX(553,1,"Q"))="S" STOP
- G EN
- NAK D FLUSH1^PSXUTL,LOG^PSXUTL
- W *NAK,*TERM
- S PSXTRYN=PSXTRYN+1 G:PSXTRYN>5 ERROR G MSG
- ND I $G(^PSX(553,1,"Q"))="S" S PSXSTOP=1 Q
- D QRY20^PSXYMSG,FLUSH1^PSXUTL,LOG^PSXUTL S PSXTRYN=PSXTRYN+1 G:PSXTRYN>5 ERROR G MSG
- RTN G:PSXCNT'>1 SLAVE
- Q:$G(PSXQRY)=0
- D BID G:$G(PSXQUIT) TST D TSOUT^PSXUTL K PSXTXT,PSXLAST S PSXBLK=1,PSXLAST=0
- S PSXTXT="MSH|^~\&|DHCP||"_$S($G(PSXVNDR)>0:"SI BAKER",1:"ELECTROCOM")_"||"_PSXTS_"||ACK|"_$G(MSGID)_"|P|2.1|" D XMIT^PSXYSND Q:$G(PSXPOP)
- S PSXBLK=2,PSXLAST=1
- S PSXTXT="MSA|"_$S(QRYFLG=0:"AA|"_$G(MSGID)_"|",QRYFLG>0:"AR|"_MSGID_"|"_$S(QRYFLG=1:"RX NUMBER",QRYFLG=2:"STATUS",QRYFLG=3:"COMPLETED DATE",QRYFLG=4:"EMPLOYEE ID",QRYFLG=5:"NO CANCELLED REASON",1:"UNKNOWN")) D XMIT^PSXYSND Q:$G(PSXPOP)
- I $G(QRYFLG)>0 S DR="1////1",DIE="^PSX(552.3," F I=2:1 S XX=$P(XDA,"^",I) Q:XX'>0 S DA=XX D ^DIE K DA
- I $G(QRYFLG)>0 K DA,DIE,DR
- W *EOT,*TERM
- D NOW^%DTC
- S $P(^PSX(553.1,PSXQRYID,0),"^",4)=%,$P(^PSX(553.1,PSXQRYID,0),"^",5)=5,$P(^PSX(553.1,PSXQRYID,0),"^",6)=$G(RXCNT)
- K MESSID,MSGID,TRY,CANFLAG
- I $G(^PSX(553,1,"Q"))="S" S PSXSTOP=1 Q
- SLAVE S BLKA=0
- R *X:PSXDLTD
- E D QRY1^PSXYMSG,LOG^PSXUTL G ND
- I X'=ENQ D QRY5^PSXYMSG S TRY=$G(TRY)+1 G:$G(TRY)'>5 SLAVE G ERROR
- R *X:PSXDLTA
- I ('$T)!(X'=TERM) D QRY14^PSXYMSG G ERROR
- W *ACK,0,*TERM
- R *X:PSXDLTD G:X=STX READ I X=EOT R *X:PSXDLTA Q:X=TERM
- MSG R *X:PSXDLTD E D QRY1^PSXYMSG,LOG^PSXUTL G ND
- I X=STX G READ
- I X=EOT R *X:PSXDLTA I X=TERM G RTN
- S QF="STX/EOT"
- D QRY5^PSXYMSG ;unexpected character received
- ERROR D FLUSH1^PSXUTL,LOG^PSXUTL S QRYPOP=1
- Q
- READ S PSXACK="" S PSXTMD=$P($H,",",2)
- GETMSG F %=1:1 D Q:'%
- .R *X:PSXDLTA E D QRY6^PSXYMSG,LOG^PSXUTL S %=0,X="" Q
- .D CHKD^PSXUTL I PSXTMOUT D QRY6^PSXYMSG,LOG^PSXUTL S %=0,X="" Q
- .I %>240 D QRY7^PSXYMSG,LOG^PSXUTL S %=0,X="" Q
- .S PSXACK=PSXACK_$C(X)
- .I (X=ETX)!(X=ETB) S %=0
- I X=ETX S PSXCNT=PSXCNT+1 G TEST
- I X=ETB G TEST
- I X=EOT R *X:PSXDLTA G:X=TERM MSG
- I (X'=ETX)!(X'=ETB)!(X'=EOT) D QRY8^PSXYMSG G NAK
- I PSXACK="" D QRY9^PSXYMSG G ERROR
- Q
- TEST R *X:PSXDLTA E D QRY10^PSXYMSG G ERROR
- I "0123456789ABCDEF"'[$C(X) D QRY11^PSXYMSG G NAK
- S PSXSUM=$C(X)
- CHKSUM R *X:PSXDLTA E D QRY10^PSXYMSG G ERROR
- I "0123456789ABCDEF"'[$C(X) D QRY11^PSXYMSG G NAK
- S PSXSUM=PSXSUM_$C(X)
- S X=PSXACK X ^%ZOSF("LPC") S PSXHEX=Y D HEX^PSXUTL
- R *X:1 I X'=TERM D QRY5^PSXYMSG
- I PSXHEX'=PSXSUM D QRY12^PSXYMSG G NAK
- I PSXHEX=PSXSUM D FLUSH1^PSXUTL
- S BLK=$E(PSXACK,1) I BLK>7 D QRY16^PSXYMSG G NAK
- I RXCNT=QLR&($E(PSXACK,7,10)'["BTS") D QRY19^PSXYMSG,LOG^PSXUTL W *EOT,*TERM Q
- I $E(PSXACK,7,10)["BTS|" S DA=PSXQRYID,PSXQRY=0,DIE="^PSX(553.1,",DR="4////1" S:RXCNT=0 PSXCNT=2 D ^DIE K DR,DA,DIE
- I $E(PSXACK,7,9)["MSA"&($P(PSXACK,"|",3)'=PSXQRYID) D QRY15^PSXYMSG G NAK
- I $E(PSXACK,7,9)["QRD"&($P(PSXACK,"|",5)'=PSXQRYID) D QRY15^PSXYMSG G NAK
- W *ACK,BLK,*TERM D FILE G MSG
- Q
- FILE I $E(PSXACK,7,10)["MSH|" S MESSID=$E(PSXACK,7,$L(PSXACK)-2),MSGID=$P(MESSID,"|",10),QRYFLG=0,XDA=""
- I $E(PSXACK,7,12)["NTE|99" D
- .S CANFLAG=0
- .S:($P($P(PSXACK,"\",1),"|",4)="")!($P($P(PSXACK,"\",1),"|",4)[" ") QRYFLG=1 Q:QRYFLG>0 S:"CACO"'[$P(PSXACK,"\F\",2) QRYFLG=2 S:$P(PSXACK,"\F\",2)["CA" CANFLAG=1 Q:QRYFLG>0
- .S:$P(PSXACK,"\F\",3)'?10.14N QRYFLG=3 Q:QRYFLG>0 S EMPID=$P(PSXACK,"\F\",5) S:$G(EMPID)="" QRYFLG=4 Q:QRYFLG>0 S:'$D(^XUSEC("PSXRPH",EMPID)) QRYFLG=4 Q:QRYFLG>0
- .I $G(EMPID)>0 N X,Y S DIC=200,DIC(0)="MNZ",X=EMPID D ^DIC K DIC S:$G(Y)<1 QRYFLG=4 K X,Y Q:QRYFLG>0
- .S RXCNT=RXCNT+1
- I $E(PSXACK,7,13)["NTE|100" S:($G(CANFLAG)>0&($P($P(PSXACK,"\",1),"|",4)="")) QRYFLG=5
- Q:BLK=BLKA
- Q:$G(QRYFLG)>0
- F1 L +^PSX(552.3,0):3 G:'$T F1 S NEW=$P(^PSX(552.3,0),"^",3)+1,$P(^PSX(552.3,0),"^",4)=$P(^PSX(552.3,0),"^",4)+1,$P(^PSX(552.3,0),"^",3)=NEW L -^PSX(552.3,0)
- G:$D(^PSX(552.3,NEW,0)) F1
- F2 L +^PSX(552.3,NEW):3 G:'$T F2 S ^PSX(552.3,NEW,0)=$E(PSXACK,7,$L(PSXACK)-2),^PSX(552.3,NEW,1)=2,^PSX(552.3,"AQ",NEW)="" L -^PSX(552.3,NEW) S XDA=$G(XDA)_"^"_NEW K NEW
- S BLKA=BLK
- Q
- XMIT S (PSXPOP,PSXTRYN)=0
- S PSXLEN=$L(PSXTXT)
- S PSXLEN=$E("00000",1,5-$L(PSXLEN))_PSXLEN
- S PSXTXT=PSXBLK_PSXLEN_PSXTXT_$S(PSXLAST:$C(ETX),1:$C(ETB))
- ;Get 2 byte hex Csum
- S X=PSXTXT X ^%ZOSF("LPC") S PSXHEX=Y D HEX^PSXUTL
- S PSXTXT=$C(STX)_PSXTXT_PSXHEX_$C(TERM)
- RETRY W PSXTXT
- S PSXBLK=$A(PSXBLK)
- TRY R *X:PSXDLTA E D SND1 G ERROR1 ;look for ACK or NAK
- I X=ACK R *X:PSXDLTA D:('$T)!(X'=PSXBLK) SND2 G:('$T)!(X'=PSXBLK) ERROR1 R *X:PSXDLTA D:('$T)!(X'=TERM) SND9 G:('$T)!(X'=TERM) ERROR1 Q
- I X=NAK R *X:PSXDLTA D:('$T)!(X'=TERM) SND3 D SND4 G ERROR1
- I X=EOT R *X:PSXDLTA D:('$T)!(X'=TERM) SND5 D SND7 G:('$T)!(X'=TERM) ERROR1 S PSXTRYN=9999 G ERROR1
- D SND6
- ERROR1 D FLUSH1^PSXUTL,LOG^PSXUTL
- S PSXTRYN=PSXTRYN+1
- S PSXBLK=$C(PSXBLK)
- G:PSXTRYN'>PSXTRYL RETRY
- S PSXPOP=1
- Q
- BID ;Set line bid retry counter
- S PSXTRY=0
- BID1 G:$P($G(^PSX(553,1,"Q")),"^")="S" STOP
- S PSXTME=$P($H,",",2)
- U IO
- W *ENQ,*TERM
- BID2 R *X:PSXDLTA E D MST6^PSXYMSG G BAD
- I X=EOT R *X:PSXDLTA G:X=TERM BID2
- I X=ENQ R *X:PSXDLTA D:'$T!(X'=TERM) MST1^PSXYMSG G:'$T!(X'=TERM) BAD S PSXTME=$P($H,",",2) S PSXTRY=PSXTRY+1 G:PSXTRY>PSXTRYM BAD D MST7^PSXYMSG,LOG^PSXUTL G BID2 ;ENQ received
- I X=NAK R *X:PSXDLTA D:'$T!(X'=TERM) MST2^PSXYMSG G:'$T!(X'=TERM) BAD D MST5^PSXYMSG,LOG^PSXUTL G BAD
- I X=ACK R *X:PSXDLTA D:'$T!(X'=48) MST3^PSXYMSG G:'$T!(X'=48) BAD R *X:PSXDLTA D:'$T!(X'=TERM) MST8^PSXYMSG G:($G(X)=TERM) OKAY
- D MST4^PSXYMSG ;if X wasn't ENQ or ACK or NAK then garbage
- BAD S PSXTRY=PSXTRY+1 D FLUSH1^PSXUTL,LOG^PSXUTL G:PSXTRY'>PSXTRYM BID1
- ;STOP interface if bid fails more that M times
- D MST9^PSXYMSG,LOG^PSXUTL,SETPAR^PSXYSTRT
- S PSXQUIT=1
- ;Hibernate awhile till CMOP comes on line,then try again
- H 45
- G ^PSXJOB
- OKAY ;Bid for Master was succesful
- S PSXTME=$P($H,",",2)
- ;Quit if Status is Stopped
- G:^PSX(553,1,"Q")="S" STOP
- Q
- STOP K LOG S LOG(1)="Stop Query interface request detected from DHCP."
- D LOG^PSXUTL
- K LOG,PSXONE S LOG(1)="Stopping the Query interface now!"
- D ^%ZISC S ZTREQ="@"
- D LOG^PSXUTL
- W "Done!"
- Q
- SND1 K LOG S LOG(1)="SND1 Timer A timeout after sending a line of text."_$G(PSXBLK) Q
- SND2 K LOG S LOG(1)="SND2 ACK Received with bad block number after sending line of text, ASCII ("_$G(X)_") "_X
- S LOG(2)="Expected ASCII ("_$G(PSXBLK)_")." Q
- SND3 K LOG S LOG(1)="SND3 NAK Received with no terminator after sending a line of text." Q
- SND4 K LOG S LOG(1)="SND4 NAK Received after sending a line of text." Q
- SND5 K LOG S LOG(1)="SND5 EOT Received with no terminator after sending a line of text." Q
- SND6 K LOG S LOG(1)="SND6 Garbage received after sending a line of text. ("_X_")" Q
- SND7 K LOG S LOG(1)="SND7 EOT Received, aborting send." Q
- SND8 K LOG S LOG(1)="SND8 Aborting Send. Error processing order # "_$P($G(^PSX(552.2,PSXQN,0)),"^",1)_". Text: "_PSXTXT Q
- SND9 K LOG S LOG(1)="SND9 ACK,"_$G(PSXBLK)_" received with no terminator after sending",LOG(2)="a line of text." Q
- PSXYQRY ;BIR/HTW-Dual Sends/Receives the Query ;[ 02/20/99 5:49 PM ]
- +1 ;;2.0;CMOP;**17**;11 Apr 97
- EN IF $PIECE($GET(^PSX(553,1,"Q")),"^")="S"
- SET PSXSTOP=1
- GOTO TST
- +1 DO NOW^%DTC
- SET XZ=$PIECE(^PSX(553.1,0),"^",3)
- SET INT=$PIECE(^PSX(553,1,0),"^",9)
- IF $GET(INT)'>0
- SET INT=1
- +2 IF $GET(XZ)
- SET LQRYTM=$PIECE(^PSX(553.1,XZ,0),"^",2)
- SET NEXTQRY=$$FMADD^XLFDT(LQRYTM,0,INT,0,0)
- +3 IF %>NEXTQRY
- GOTO EN1
- +4 IF %'>NEXTQRY
- HANG $$FMDIFF^XLFDT(%,LQRYTM,2)
- EN1 SET (PSXCNT,PSXTRYN,RXCNT)=0
- SET QLR=$PIECE($GET(^PSX(553,1,0)),"^",8)
- +1 KILL DD,DO
- +2 SET (DA,X)=$PIECE(^PSX(553.1,0),U,3)+1
- SET DIC="^PSX(553.1,"
- SET DIC(0)="LZ"
- SET DIC("DR")="1////"_%_";4////1"
- SET DLAYGO=553.1
- F DO FILE^DICN
- SET PSXQRYID=+Y
- SET LOG(1)="QUERY # "_PSXQRYID_" initiated."_$GET(PSXQRYA)
- DO LOG^PSXUTL
- +1 IF $PIECE($GET(^PSX(553,1,"Q")),"^")="S"
- SET PSXSTOP=1
- GOTO TST
- +2 KILL DA,DIC,DUOUT,DTOUT,DLAYGO,X,Y,%,DINUM,PSXPOP,TRY
- +3 SET PSXQRY=1
- DO BID
- IF $GET(PSXQUIT)
- GOTO TST
- +4 DO TSOUT^PSXUTL
- +5 SET PSXBLK=1
- SET PSXLAST=0
- +6 SET PSXTXT="MSH|^~\&|DHCP||"_$SELECT($GET(PSXVNDR)>1:"SI BAKER",$GET(PSXVNDR)=1:"ELECTROCOM",1:"ELECTROCOM")_"||"_PSXTS_"||QRY|"_PSXQRYID_"|P|2.1|"
- DO XMIT^PSXYSND
- IF $GET(PSXPOP)
- GOTO TST
- +7 SET PSXBLK=2
- SET PSXLAST=1
- SET PSXTXT="QRD|"_PSXTS_"|R|I|"_PSXQRYID_"|||"_QLR_"^ZO|OP|OTH|ALL"
- DO XMIT^PSXYSND
- IF $GET(PSXPOP)
- GOTO TST
- +8 WRITE *EOT,*TERM
- +9 DO SLAVE
- TST DO FLUSH1^PSXUTL
- +1 SET LOG(1)="QUERY # "_$GET(PSXQRYID)_" completed."_$GET(PSXQRYA)
- IF $GET(PSXSTOP)
- SET LOG(2)="DHCP STOPPED QUERY "_$GET(PSXQRYID)
- IF $GET(PSXQUIT)
- SET LOG(3)="No Response to Bid, DHCP terminated query."
- DO LOG^PSXUTL
- +2 SET $PIECE(^PSX(554,1,0),"^",3)=$GET(PSXQRYID)
- +3 KILL PSXHEX,PSXACK,LOG,BLK,BLKA,PSXQRYID,PSXTXT,PSXBLK,%,X,Y,PSXLAST,QLR,MESSID,MSGID,RXCNT,PSXQRY,PSXQRYA,PSXSTOP,PSXPOP,PSXQUIT
- +4 SET ZTREQ="@"
- +5 IF $GET(^PSX(553,1,"Q"))="S"
- GOTO STOP
- +6 GOTO EN
- NAK DO FLUSH1^PSXUTL
- DO LOG^PSXUTL
- +1 WRITE *NAK,*TERM
- +2 SET PSXTRYN=PSXTRYN+1
- IF PSXTRYN>5
- GOTO ERROR
- GOTO MSG
- ND IF $GET(^PSX(553,1,"Q"))="S"
- SET PSXSTOP=1
- QUIT
- +1 DO QRY20^PSXYMSG
- DO FLUSH1^PSXUTL
- DO LOG^PSXUTL
- SET PSXTRYN=PSXTRYN+1
- IF PSXTRYN>5
- GOTO ERROR
- GOTO MSG
- RTN IF PSXCNT'>1
- GOTO SLAVE
- +1 IF $GET(PSXQRY)=0
- QUIT
- +2 DO BID
- IF $GET(PSXQUIT)
- GOTO TST
- DO TSOUT^PSXUTL
- KILL PSXTXT,PSXLAST
- SET PSXBLK=1
- SET PSXLAST=0
- +3 SET PSXTXT="MSH|^~\&|DHCP||"_$SELECT($GET(PSXVNDR)>0:"SI BAKER",1:"ELECTROCOM")_"||"_PSXTS_"||ACK|"_$GET(MSGID)_"|P|2.1|"
- DO XMIT^PSXYSND
- IF $GET(PSXPOP)
- QUIT
- +4 SET PSXBLK=2
- SET PSXLAST=1
- +5 SET PSXTXT="MSA|"_$SELECT(QRYFLG=0:"AA|"_$GET(MSGID)_"|",QRYFLG>0:"AR|"_MSGID_"|"_$SELECT(QRYFLG=1:"RX NUMBER",QRYFLG=2:"STATUS",QRYFLG=3:"COMPLETED DATE",QRYFLG=4:"EMPLOYEE ID",QRYFLG=5:"NO CANCELLED REASON",1:"UNKNOWN"))
- DO XMIT^PSXYSND
- IF $GET(PSXPOP)
- QUIT
- +6 IF $GET(QRYFLG)>0
- SET DR="1////1"
- SET DIE="^PSX(552.3,"
- FOR I=2:1
- SET XX=$PIECE(XDA,"^",I)
- IF XX'>0
- QUIT
- SET DA=XX
- DO ^DIE
- KILL DA
- +7 IF $GET(QRYFLG)>0
- KILL DA,DIE,DR
- +8 WRITE *EOT,*TERM
- +9 DO NOW^%DTC
- +10 SET $PIECE(^PSX(553.1,PSXQRYID,0),"^",4)=%
- SET $PIECE(^PSX(553.1,PSXQRYID,0),"^",5)=5
- SET $PIECE(^PSX(553.1,PSXQRYID,0),"^",6)=$GET(RXCNT)
- +11 KILL MESSID,MSGID,TRY,CANFLAG
- +12 IF $GET(^PSX(553,1,"Q"))="S"
- SET PSXSTOP=1
- QUIT
- SLAVE SET BLKA=0
- +1 READ *X:PSXDLTD
- +2 IF '$TEST
- DO QRY1^PSXYMSG
- DO LOG^PSXUTL
- GOTO ND
- +3 IF X'=ENQ
- DO QRY5^PSXYMSG
- SET TRY=$GET(TRY)+1
- IF $GET(TRY)'>5
- GOTO SLAVE
- GOTO ERROR
- +4 READ *X:PSXDLTA
- +5 IF ('$TEST)!(X'=TERM)
- DO QRY14^PSXYMSG
- GOTO ERROR
- +6 WRITE *ACK,0,*TERM
- +7 READ *X:PSXDLTD
- IF X=STX
- GOTO READ
- IF X=EOT
- READ *X:PSXDLTA
- IF X=TERM
- QUIT
- MSG READ *X:PSXDLTD
- IF '$TEST
- DO QRY1^PSXYMSG
- DO LOG^PSXUTL
- GOTO ND
- +1 IF X=STX
- GOTO READ
- +2 IF X=EOT
- READ *X:PSXDLTA
- IF X=TERM
- GOTO RTN
- +3 SET QF="STX/EOT"
- +4 ;unexpected character received
- DO QRY5^PSXYMSG
- ERROR DO FLUSH1^PSXUTL
- DO LOG^PSXUTL
- SET QRYPOP=1
- +1 QUIT
- READ SET PSXACK=""
- SET PSXTMD=$PIECE($HOROLOG,",",2)
- GETMSG FOR %=1:1
- Begin DoDot:1
- +1 READ *X:PSXDLTA
- IF '$TEST
- DO QRY6^PSXYMSG
- DO LOG^PSXUTL
- SET %=0
- SET X=""
- QUIT
- +2 DO CHKD^PSXUTL
- IF PSXTMOUT
- DO QRY6^PSXYMSG
- DO LOG^PSXUTL
- SET %=0
- SET X=""
- QUIT
- +3 IF %>240
- DO QRY7^PSXYMSG
- DO LOG^PSXUTL
- SET %=0
- SET X=""
- QUIT
- +4 SET PSXACK=PSXACK_$CHAR(X)
- +5 IF (X=ETX)!(X=ETB)
- SET %=0
- End DoDot:1
- IF '%
- QUIT
- +6 IF X=ETX
- SET PSXCNT=PSXCNT+1
- GOTO TEST
- +7 IF X=ETB
- GOTO TEST
- +8 IF X=EOT
- READ *X:PSXDLTA
- IF X=TERM
- GOTO MSG
- +9 IF (X'=ETX)!(X'=ETB)!(X'=EOT)
- DO QRY8^PSXYMSG
- GOTO NAK
- +10 IF PSXACK=""
- DO QRY9^PSXYMSG
- GOTO ERROR
- +11 QUIT
- TEST READ *X:PSXDLTA
- IF '$TEST
- DO QRY10^PSXYMSG
- GOTO ERROR
- +1 IF "0123456789ABCDEF"'[$CHAR(X)
- DO QRY11^PSXYMSG
- GOTO NAK
- +2 SET PSXSUM=$CHAR(X)
- CHKSUM READ *X:PSXDLTA
- IF '$TEST
- DO QRY10^PSXYMSG
- GOTO ERROR
- +1 IF "0123456789ABCDEF"'[$CHAR(X)
- DO QRY11^PSXYMSG
- GOTO NAK
- +2 SET PSXSUM=PSXSUM_$CHAR(X)
- +3 SET X=PSXACK
- XECUTE ^%ZOSF("LPC")
- SET PSXHEX=Y
- DO HEX^PSXUTL
- +4 READ *X:1
- IF X'=TERM
- DO QRY5^PSXYMSG
- +5 IF PSXHEX'=PSXSUM
- DO QRY12^PSXYMSG
- GOTO NAK
- +6 IF PSXHEX=PSXSUM
- DO FLUSH1^PSXUTL
- +7 SET BLK=$EXTRACT(PSXACK,1)
- IF BLK>7
- DO QRY16^PSXYMSG
- GOTO NAK
- +8 IF RXCNT=QLR&($EXTRACT(PSXACK,7,10)'["BTS")
- DO QRY19^PSXYMSG
- DO LOG^PSXUTL
- WRITE *EOT,*TERM
- QUIT
- +9 IF $EXTRACT(PSXACK,7,10)["BTS|"
- SET DA=PSXQRYID
- SET PSXQRY=0
- SET DIE="^PSX(553.1,"
- SET DR="4////1"
- IF RXCNT=0
- SET PSXCNT=2
- DO ^DIE
- KILL DR,DA,DIE
- +10 IF $EXTRACT(PSXACK,7,9)["MSA"&($PIECE(PSXACK,"|",3)'=PSXQRYID)
- DO QRY15^PSXYMSG
- GOTO NAK
- +11 IF $EXTRACT(PSXACK,7,9)["QRD"&($PIECE(PSXACK,"|",5)'=PSXQRYID)
- DO QRY15^PSXYMSG
- GOTO NAK
- +12 WRITE *ACK,BLK,*TERM
- DO FILE
- GOTO MSG
- +13 QUIT
- FILE IF $EXTRACT(PSXACK,7,10)["MSH|"
- SET MESSID=$EXTRACT(PSXACK,7,$LENGTH(PSXACK)-2)
- SET MSGID=$PIECE(MESSID,"|",10)
- SET QRYFLG=0
- SET XDA=""
- +1 IF $EXTRACT(PSXACK,7,12)["NTE|99"
- Begin DoDot:1
- +2 SET CANFLAG=0
- +3 IF ($PIECE($PIECE(PSXACK,"\",1),"|",4)="")!($PIECE($PIECE(PSXACK,"\",1),"|",4)[" ")
- SET QRYFLG=1
- IF QRYFLG>0
- QUIT
- IF "CACO"'[$PIECE(PSXACK,"\F\",2)
- SET QRYFLG=2
- IF $PIECE(PSXACK,"\F\",2)["CA"
- SET CANFLAG=1
- IF QRYFLG>0
- QUIT
- +4 IF $PIECE(PSXACK,"\F\",3)'?10.14N
- SET QRYFLG=3
- IF QRYFLG>0
- QUIT
- SET EMPID=$PIECE(PSXACK,"\F\",5)
- IF $GET(EMPID)=""
- SET QRYFLG=4
- IF QRYFLG>0
- QUIT
- IF '$DATA(^XUSEC("PSXRPH",EMPID))
- SET QRYFLG=4
- IF QRYFLG>0
- QUIT
- +5 IF $GET(EMPID)>0
- NEW X,Y
- SET DIC=200
- SET DIC(0)="MNZ"
- SET X=EMPID
- DO ^DIC
- KILL DIC
- IF $GET(Y)<1
- SET QRYFLG=4
- KILL X,Y
- IF QRYFLG>0
- QUIT
- +6 SET RXCNT=RXCNT+1
- End DoDot:1
- +7 IF $EXTRACT(PSXACK,7,13)["NTE|100"
- IF ($GET(CANFLAG)>0&($PIECE($PIECE(PSXACK,"\",1),"|",4)=""))
- SET QRYFLG=5
- +8 IF BLK=BLKA
- QUIT
- +9 IF $GET(QRYFLG)>0
- QUIT
- F1 LOCK +^PSX(552.3,0):3
- IF '$TEST
- GOTO F1
- SET NEW=$PIECE(^PSX(552.3,0),"^",3)+1
- SET $PIECE(^PSX(552.3,0),"^",4)=$PIECE(^PSX(552.3,0),"^",4)+1
- SET $PIECE(^PSX(552.3,0),"^",3)=NEW
- LOCK -^PSX(552.3,0)
- +1 IF $DATA(^PSX(552.3,NEW,0))
- GOTO F1
- F2 LOCK +^PSX(552.3,NEW):3
- IF '$TEST
- GOTO F2
- SET ^PSX(552.3,NEW,0)=$EXTRACT(PSXACK,7,$LENGTH(PSXACK)-2)
- SET ^PSX(552.3,NEW,1)=2
- SET ^PSX(552.3,"AQ",NEW)=""
- LOCK -^PSX(552.3,NEW)
- SET XDA=$GET(XDA)_"^"_NEW
- KILL NEW
- +1 SET BLKA=BLK
- +2 QUIT
- XMIT SET (PSXPOP,PSXTRYN)=0
- +1 SET PSXLEN=$LENGTH(PSXTXT)
- +2 SET PSXLEN=$EXTRACT("00000",1,5-$LENGTH(PSXLEN))_PSXLEN
- +3 SET PSXTXT=PSXBLK_PSXLEN_PSXTXT_$SELECT(PSXLAST:$CHAR(ETX),1:$CHAR(ETB))
- +4 ;Get 2 byte hex Csum
- +5 SET X=PSXTXT
- XECUTE ^%ZOSF("LPC")
- SET PSXHEX=Y
- DO HEX^PSXUTL
- +6 SET PSXTXT=$CHAR(STX)_PSXTXT_PSXHEX_$CHAR(TERM)
- RETRY WRITE PSXTXT
- +1 SET PSXBLK=$ASCII(PSXBLK)
- TRY ;look for ACK or NAK
- READ *X:PSXDLTA
- IF '$TEST
- DO SND1
- GOTO ERROR1
- +1 IF X=ACK
- READ *X:PSXDLTA
- IF ('$TEST)!(X'=PSXBLK)
- DO SND2
- IF ('$TEST)!(X'=PSXBLK)
- GOTO ERROR1
- READ *X:PSXDLTA
- IF ('$TEST)!(X'=TERM)
- DO SND9
- IF ('$TEST)!(X'=TERM)
- GOTO ERROR1
- QUIT
- +2 IF X=NAK
- READ *X:PSXDLTA
- IF ('$TEST)!(X'=TERM)
- DO SND3
- DO SND4
- GOTO ERROR1
- +3 IF X=EOT
- READ *X:PSXDLTA
- IF ('$TEST)!(X'=TERM)
- DO SND5
- DO SND7
- IF ('$TEST)!(X'=TERM)
- GOTO ERROR1
- SET PSXTRYN=9999
- GOTO ERROR1
- +4 DO SND6
- ERROR1 DO FLUSH1^PSXUTL
- DO LOG^PSXUTL
- +1 SET PSXTRYN=PSXTRYN+1
- +2 SET PSXBLK=$CHAR(PSXBLK)
- +3 IF PSXTRYN'>PSXTRYL
- GOTO RETRY
- +4 SET PSXPOP=1
- +5 QUIT
- BID ;Set line bid retry counter
- +1 SET PSXTRY=0
- BID1 IF $PIECE($GET(^PSX(553,1,"Q")),"^")="S"
- GOTO STOP
- +1 SET PSXTME=$PIECE($HOROLOG,",",2)
- +2 USE IO
- +3 WRITE *ENQ,*TERM
- BID2 READ *X:PSXDLTA
- IF '$TEST
- DO MST6^PSXYMSG
- GOTO BAD
- +1 IF X=EOT
- READ *X:PSXDLTA
- IF X=TERM
- GOTO BID2
- +2 ;ENQ received
- IF X=ENQ
- READ *X:PSXDLTA
- IF '$TEST!(X'=TERM)
- DO MST1^PSXYMSG
- IF '$TEST!(X'=TERM)
- GOTO BAD
- SET PSXTME=$PIECE($HOROLOG,",",2)
- SET PSXTRY=PSXTRY+1
- IF PSXTRY>PSXTRYM
- GOTO BAD
- DO MST7^PSXYMSG
- DO LOG^PSXUTL
- GOTO BID2
- +3 IF X=NAK
- READ *X:PSXDLTA
- IF '$TEST!(X'=TERM)
- DO MST2^PSXYMSG
- IF '$TEST!(X'=TERM)
- GOTO BAD
- DO MST5^PSXYMSG
- DO LOG^PSXUTL
- GOTO BAD
- +4 IF X=ACK
- READ *X:PSXDLTA
- IF '$TEST!(X'=48)
- DO MST3^PSXYMSG
- IF '$TEST!(X'=48)
- GOTO BAD
- READ *X:PSXDLTA
- IF '$TEST!(X'=TERM)
- DO MST8^PSXYMSG
- IF ($GET(X)=TERM)
- GOTO OKAY
- +5 ;if X wasn't ENQ or ACK or NAK then garbage
- DO MST4^PSXYMSG
- BAD SET PSXTRY=PSXTRY+1
- DO FLUSH1^PSXUTL
- DO LOG^PSXUTL
- IF PSXTRY'>PSXTRYM
- GOTO BID1
- +1 ;STOP interface if bid fails more that M times
- +2 DO MST9^PSXYMSG
- DO LOG^PSXUTL
- DO SETPAR^PSXYSTRT
- +3 SET PSXQUIT=1
- +4 ;Hibernate awhile till CMOP comes on line,then try again
- +5 HANG 45
- +6 GOTO ^PSXJOB
- OKAY ;Bid for Master was succesful
- +1 SET PSXTME=$PIECE($HOROLOG,",",2)
- +2 ;Quit if Status is Stopped
- +3 IF ^PSX(553,1,"Q")="S"
- GOTO STOP
- +4 QUIT
- STOP KILL LOG
- SET LOG(1)="Stop Query interface request detected from DHCP."
- +1 DO LOG^PSXUTL
- +2 KILL LOG,PSXONE
- SET LOG(1)="Stopping the Query interface now!"
- +3 DO ^%ZISC
- SET ZTREQ="@"
- +4 DO LOG^PSXUTL
- +5 WRITE "Done!"
- +6 QUIT
- SND1 KILL LOG
- SET LOG(1)="SND1 Timer A timeout after sending a line of text."_$GET(PSXBLK)
- QUIT
- SND2 KILL LOG
- SET LOG(1)="SND2 ACK Received with bad block number after sending line of text, ASCII ("_$GET(X)_") "_X
- +1 SET LOG(2)="Expected ASCII ("_$GET(PSXBLK)_")."
- QUIT
- SND3 KILL LOG
- SET LOG(1)="SND3 NAK Received with no terminator after sending a line of text."
- QUIT
- SND4 KILL LOG
- SET LOG(1)="SND4 NAK Received after sending a line of text."
- QUIT
- SND5 KILL LOG
- SET LOG(1)="SND5 EOT Received with no terminator after sending a line of text."
- QUIT
- SND6 KILL LOG
- SET LOG(1)="SND6 Garbage received after sending a line of text. ("_X_")"
- QUIT
- SND7 KILL LOG
- SET LOG(1)="SND7 EOT Received, aborting send."
- QUIT
- SND8 KILL LOG
- SET LOG(1)="SND8 Aborting Send. Error processing order # "_$PIECE($GET(^PSX(552.2,PSXQN,0)),"^",1)_". Text: "_PSXTXT
- QUIT
- SND9 KILL LOG
- SET LOG(1)="SND9 ACK,"_$GET(PSXBLK)_" received with no terminator after sending"
- SET LOG(2)="a line of text."
- QUIT