ACHSTCK1 ; IHS/ITSC/PMF - CHS TELECOMMUNICATION PROGRAM ; [ 10/31/2003 11:57 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,7,21**;JUNE 11, 2001;Build 43
;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Replace direct ref to non-package global.
;ITSC/SET/JVK ACHS*3.1*7 7/21/03 - Replace code for Cache
;ACHS*3.1*21 ADDED M15 ERROR MESSAGE
Q ;NOT AN ENTRY POINT
;
OHFSDOC ;;VARIABLES REQUIRED FOR OPENHFS CALL
;;
;; ACHSZDEV -- IF OPEN SUCCESSFUL, RETURNS DEVICE NUMBER
;; ACHSZFN -- FILE NAME (FULL PATH IF NEC)
;; ACHSEMSG -- CONTAINS ERROR MESSAGE
;; ACHSZZA -- CONTAINS COMPLETION CODE (NON-ZERO = ERROR)
;; ACHSZIN -- OPEN PARAMETER (1=READ ONLY) DEFAULT VALUE
;; ACHSZFO -- FILE OFFSET (DEFAULT = 0)
;
OPENHFS ;EP
;S ACHSEMSG="",ACHSZZA=0,ACHSZDEV=50;IHS/SET/GTH ACHS*3.1*5 12/06/2002
S ACHSEMSG="",ACHSZZA=0,ACHSZDEV=0 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;by starting at 50 instead of 0, we skip over several
;devices we DON'T want ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 Except "50" is MSM specific.
;
I '$D(ACHSZIN) S ACHSZIN=1
I '$D(ACHSZFO) S ACHSZFO=0
OPENHFSA ;
S ACHSZDEV=$O(^%ZIS(1,ACHSZDEV))
G OPENEND:+ACHSZDEV=0
;I $D(^%ZIS(1,ACHSZDEV,"TYPE"))'=1 G OPENHFSA;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;G OPENHFSC:^%ZIS(1,ACHSZDEV,"TYPE")="HFS";IHS/SET/GTH ACHS*3.1*5 12/06/2002
;G OPENHFSC:$$GET1^DIQ(3.5,ACHSZDEV,2,"I")="HFS" ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
I $$GET1^DIQ(3.5,ACHSZDEV,2,"I")="HFS",$$GET1^DIQ(3.5,ACHSZDEV,.01,"I")="HFS" G OPENHFSC ;IHS/SET/JVK ACHS*3.1*7 7/2/2003
G OPENHFSA
;
OPENHFSC ;
;IHS/SET/JVK ACHS*3.1*7 7/2/2003 REPLACE ORIGINAL CODE WITH NXT 8 LNS.
S ZISH1=$P(ACHSZFN,"/",1,4)_"/"
S ZISH2=$P(ACHSZFN,"/",5)
S ZISH3=$S(ACHSZIN=1:"R",ACHSZIN=0:"W",1:"R")
S Y=$$OPEN^%ZISH(ZISH1,ZISH2,ZISH3)
U IO S ACHSZZA=$$STATUS^%ZISH
I ACHSZZA S ACHSEMSG="M10" D CLOSE^%ZISH
E S ACHSZDEV=IO
Q
;IHS/SET/JVK ACHS*3.1*7 END NEW CODE
;I '$D(ACHSZDLM),ACHSZIN=1 S %ZIS("IOPAR")="("""_ACHSZFN_""":""R"":"""_ACHSZFO_""")"
;I $D(ACHSZDLM),ACHSZIN=1 S %ZIS("IOPAR")="("""_ACHSZFN_""":""R"":"""_ACHSZFO_""":::"""_ACHSZDLM_""")"
;I '$D(ACHSZDLM),ACHSZIN'=1 S %ZIS("IOPAR")="("""_ACHSZFN_""":""M"":"""_ACHSZFO_""")"
;I $D(ACHSZDLM),ACHSZIN'=1 S %ZIS("IOPAR")="("""_ACHSZFN_""":""M"":"""_ACHSZFO_""":::"""_ACHSZDLM_""")"
;S IOP=$P(^%ZIS(1,ACHSZDEV,0),U) ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;S IOP=$$GET1^DIQ(3.5,ACHSZDEV,.01) ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;D ^%ZIS
;I POP G OPENHFSA
;U IO S ACHSZZA=$$STATUS^%ZISH
;I ACHSZZA S ACHSEMSG="M10" D ^%ZISC
;S ACHSZDEV=IO
;Q
;
OPENEND ;
S ACHSEMSG="M8",ACHSZZA=-1
Q
;
ERROR ;EP
I '$D(ACHSEMSG) D ERROREX Q
S X=$P($T(@ACHSEMSG),";;",2)
D HOME^%ZIS
U IO(0)
W !!,*7,$$C^XBFUNC(X,80),!
I $$DIR^XBDIR("E","Enter <RETURN> to Continue")
ERROREX ;
S ACHSJFLG=1
K ACHSEMSG
Q
;
CRTSETUP ;EP
D HOME^%ZIS
S ACHSXY=$P(^%ZIS(2,IOST(0),1),U,5)
I '$D(^%ZIS(1,IOS,"SUBTYPE")) G BTRMDEF
I '$D(^%ZIS(1,IOS,"TYPE")) G BTRMDEF
I ^%ZIS(1,IOS,"TYPE")'="TRM" G BTRMDEF
I '$D(^%ZIS(2,IOST(0),5)) G BTRMDEF
S ACHSLE=$P(^%ZIS(2,IOST(0),5),U,6)
S ACHSLE="W "_ACHSLE
S ACHSRVON=$P(^%ZIS(2,IOST(0),5),U,4)
S ACHSRVOF=$P(^%ZIS(2,IOST(0),5),U,5)
S X=0 X ^%ZOSF("RM")
Q
;
BTRMDEF ;
W !!!,"PROPER TERMINAL ATTRIBUTES MISSING - NOTIFY SITE MANAGER",!!
H 3
Q
;
M1 ;;COMPUTER CENTER FOR TELECOMMUNICATIONS NOT CORRECTLY DEFINED
M2 ;;IHS COMM PARAMETERS NOT SET FOR THIS LOCATION
M3 ;;3780 TELECOMMUNICATIONS PORT NOT DEFINED
M4 ;;REMOTE NUMBER NOT DEFINED FOR THIS COMPUTER CENTER"
M5 ;;USER ID OR USER PASSWORD NOT DEFINED
M6 ;;DEFAULT 3780 COMMUNICATION PORT IN USE
M7 ;;ALL 3780 COMMUNICATION PORTS ARE BUSY
M8 ;;ALL HFS DEVICES ARE BUSY
M9 ;;PROGRAM AND/OR FUNCTION CANCELLED BY OPERATOR
M10 ;;OPEN FAILURE ON HFS FILE
M11 ;;DEFAULT PRINTER PORT NOT CORRECTLY DEFINED
M12 ;;PRINTER SET-UP ERROR -- NOTIFY SUPERVISOR
M13 ;;EXPORT AND/OR APPLICATION PARAMETERS NOT SET CORRECTLY
M14 ;;Package Prefix not found in IHS COMMUNICATIONS PARAMETERS file
M15 ;;No Files to process
ACHSTCK1 ; IHS/ITSC/PMF - CHS TELECOMMUNICATION PROGRAM ; [ 10/31/2003 11:57 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,7,21**;JUNE 11, 2001;Build 43
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Replace direct ref to non-package global.
+3 ;ITSC/SET/JVK ACHS*3.1*7 7/21/03 - Replace code for Cache
+4 ;ACHS*3.1*21 ADDED M15 ERROR MESSAGE
+5 ;NOT AN ENTRY POINT
QUIT
+6 ;
OHFSDOC ;;VARIABLES REQUIRED FOR OPENHFS CALL
+1 ;;
+2 ;; ACHSZDEV -- IF OPEN SUCCESSFUL, RETURNS DEVICE NUMBER
+3 ;; ACHSZFN -- FILE NAME (FULL PATH IF NEC)
+4 ;; ACHSEMSG -- CONTAINS ERROR MESSAGE
+5 ;; ACHSZZA -- CONTAINS COMPLETION CODE (NON-ZERO = ERROR)
+6 ;; ACHSZIN -- OPEN PARAMETER (1=READ ONLY) DEFAULT VALUE
+7 ;; ACHSZFO -- FILE OFFSET (DEFAULT = 0)
+8 ;
OPENHFS ;EP
+1 ;S ACHSEMSG="",ACHSZZA=0,ACHSZDEV=50;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
SET ACHSEMSG=""
SET ACHSZZA=0
SET ACHSZDEV=0
+3 ;by starting at 50 instead of 0, we skip over several
+4 ;devices we DON'T want ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 Except "50" is MSM specific.
+5 ;
+6 IF '$DATA(ACHSZIN)
SET ACHSZIN=1
+7 IF '$DATA(ACHSZFO)
SET ACHSZFO=0
OPENHFSA ;
+1 SET ACHSZDEV=$ORDER(^%ZIS(1,ACHSZDEV))
+2 IF +ACHSZDEV=0
GOTO OPENEND
+3 ;I $D(^%ZIS(1,ACHSZDEV,"TYPE"))'=1 G OPENHFSA;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+4 ;G OPENHFSC:^%ZIS(1,ACHSZDEV,"TYPE")="HFS";IHS/SET/GTH ACHS*3.1*5 12/06/2002
+5 ;G OPENHFSC:$$GET1^DIQ(3.5,ACHSZDEV,2,"I")="HFS" ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+6 ;IHS/SET/JVK ACHS*3.1*7 7/2/2003
IF $$GET1^DIQ(3.5,ACHSZDEV,2,"I")="HFS"
IF $$GET1^DIQ(3.5,ACHSZDEV,.01,"I")="HFS"
GOTO OPENHFSC
+7 GOTO OPENHFSA
+8 ;
OPENHFSC ;
+1 ;IHS/SET/JVK ACHS*3.1*7 7/2/2003 REPLACE ORIGINAL CODE WITH NXT 8 LNS.
+2 SET ZISH1=$PIECE(ACHSZFN,"/",1,4)_"/"
+3 SET ZISH2=$PIECE(ACHSZFN,"/",5)
+4 SET ZISH3=$SELECT(ACHSZIN=1:"R",ACHSZIN=0:"W",1:"R")
+5 SET Y=$$OPEN^%ZISH(ZISH1,ZISH2,ZISH3)
+6 USE IO
SET ACHSZZA=$$STATUS^%ZISH
+7 IF ACHSZZA
SET ACHSEMSG="M10"
DO CLOSE^%ZISH
+8 IF '$TEST
SET ACHSZDEV=IO
+9 QUIT
+10 ;IHS/SET/JVK ACHS*3.1*7 END NEW CODE
+11 ;I '$D(ACHSZDLM),ACHSZIN=1 S %ZIS("IOPAR")="("""_ACHSZFN_""":""R"":"""_ACHSZFO_""")"
+12 ;I $D(ACHSZDLM),ACHSZIN=1 S %ZIS("IOPAR")="("""_ACHSZFN_""":""R"":"""_ACHSZFO_""":::"""_ACHSZDLM_""")"
+13 ;I '$D(ACHSZDLM),ACHSZIN'=1 S %ZIS("IOPAR")="("""_ACHSZFN_""":""M"":"""_ACHSZFO_""")"
+14 ;I $D(ACHSZDLM),ACHSZIN'=1 S %ZIS("IOPAR")="("""_ACHSZFN_""":""M"":"""_ACHSZFO_""":::"""_ACHSZDLM_""")"
+15 ;S IOP=$P(^%ZIS(1,ACHSZDEV,0),U) ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+16 ;S IOP=$$GET1^DIQ(3.5,ACHSZDEV,.01) ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+17 ;D ^%ZIS
+18 ;I POP G OPENHFSA
+19 ;U IO S ACHSZZA=$$STATUS^%ZISH
+20 ;I ACHSZZA S ACHSEMSG="M10" D ^%ZISC
+21 ;S ACHSZDEV=IO
+22 ;Q
+23 ;
OPENEND ;
+1 SET ACHSEMSG="M8"
SET ACHSZZA=-1
+2 QUIT
+3 ;
ERROR ;EP
+1 IF '$DATA(ACHSEMSG)
DO ERROREX
QUIT
+2 SET X=$PIECE($TEXT(@ACHSEMSG),";;",2)
+3 DO HOME^%ZIS
+4 USE IO(0)
+5 WRITE !!,*7,$$C^XBFUNC(X,80),!
+6 IF $$DIR^XBDIR("E","Enter <RETURN> to Continue")
ERROREX ;
+1 SET ACHSJFLG=1
+2 KILL ACHSEMSG
+3 QUIT
+4 ;
CRTSETUP ;EP
+1 DO HOME^%ZIS
+2 SET ACHSXY=$PIECE(^%ZIS(2,IOST(0),1),U,5)
+3 IF '$DATA(^%ZIS(1,IOS,"SUBTYPE"))
GOTO BTRMDEF
+4 IF '$DATA(^%ZIS(1,IOS,"TYPE"))
GOTO BTRMDEF
+5 IF ^%ZIS(1,IOS,"TYPE")'="TRM"
GOTO BTRMDEF
+6 IF '$DATA(^%ZIS(2,IOST(0),5))
GOTO BTRMDEF
+7 SET ACHSLE=$PIECE(^%ZIS(2,IOST(0),5),U,6)
+8 SET ACHSLE="W "_ACHSLE
+9 SET ACHSRVON=$PIECE(^%ZIS(2,IOST(0),5),U,4)
+10 SET ACHSRVOF=$PIECE(^%ZIS(2,IOST(0),5),U,5)
+11 SET X=0
XECUTE ^%ZOSF("RM")
+12 QUIT
+13 ;
BTRMDEF ;
+1 WRITE !!!,"PROPER TERMINAL ATTRIBUTES MISSING - NOTIFY SITE MANAGER",!!
+2 HANG 3
+3 QUIT
+4 ;
M1 ;;COMPUTER CENTER FOR TELECOMMUNICATIONS NOT CORRECTLY DEFINED
M2 ;;IHS COMM PARAMETERS NOT SET FOR THIS LOCATION
M3 ;;3780 TELECOMMUNICATIONS PORT NOT DEFINED
M4 ;;REMOTE NUMBER NOT DEFINED FOR THIS COMPUTER CENTER"
M5 ;;USER ID OR USER PASSWORD NOT DEFINED
M6 ;;DEFAULT 3780 COMMUNICATION PORT IN USE
M7 ;;ALL 3780 COMMUNICATION PORTS ARE BUSY
M8 ;;ALL HFS DEVICES ARE BUSY
M9 ;;PROGRAM AND/OR FUNCTION CANCELLED BY OPERATOR
M10 ;;OPEN FAILURE ON HFS FILE
M11 ;;DEFAULT PRINTER PORT NOT CORRECTLY DEFINED
M12 ;;PRINTER SET-UP ERROR -- NOTIFY SUPERVISOR
M13 ;;EXPORT AND/OR APPLICATION PARAMETERS NOT SET CORRECTLY
M14 ;;Package Prefix not found in IHS COMMUNICATIONS PARAMETERS file
M15 ;;No Files to process
