ACHSTCK1.m

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