Routine: RA12PST2

RA12PST2 ;HIRMFO/CRT - Post-init functions (patch seventeen) ;5/20/99

VERSION ;;5.0;Radiology/Nuclear Medicine;**17**;Mar 16, 1998

MSG(ENTRY,FILE,ERR) ; display a status message pertaining to the addition

 ; of entries to files: 870 & 101.  Display a status message

 ; when items are added to the Protocol (101) file.

 ; Variable list:

 ; ENTRY-> value of the .01 field for a particular file (60 chars max)

 ; FILE -> file # where the data will be added

 ; ERR  -> err message? 1 if yes, else null

 N RACNT,RATXT,STRING,WORDS S RACNT=1,RATXT(RACNT)=" "

 S:$G(ERR) STRING="* ERROR * "

 S STRING=$G(STRING)_"Adding/Editing '"_$E(ENTRY,1,40)_"' in the "

 S STRING=$G(STRING)_$E($P($G(^DIC(FILE,0)),"^"),1,40)_" file."

 S:$G(ERR)&($D(DIERR)) STRING=$G(STRING)_" "_$E($G(^TMP("DIERR",$J,1,"TEXT",1)),1,115) ; display the 1st error text encountered! (there may be more errors. Because of possible string length error display only the first error.)

 S:$G(ERR) STRING=$G(STRING)_" IRM should investigate."

 F  D  Q:STRING=""

 . S WORDS=$L($E(STRING,1,71)," ")

 . S RACNT=RACNT+1,RATXT(RACNT)=$P(STRING," ",1,WORDS)

 . S STRING=$P(STRING," ",WORDS+1,999)

. Q

 D MES^XPDUTL(.RATXT)

CLIENT() ; return 'CLIENT (SENDER)', for CLIENT/SERVER (400.03) field

 ; in file 870

 Q "CLIENT (SENDER)"

N() ; return 'NO', for various fields in file 101

 Q "NO"

SLISTN() ; return 'SINGLE LISTENER', for CLIENT/SERVER (400.03) field

 ; in file 870

 Q "SINGLE LISTENER"

TCP() ; return 'TCP' for LLP TYPE (2) field in file 870

 Q "TCP"

Y() ; return 'YES', for PERSISTENT (400.04) field in file 870

 Q "YES"

PKG() ; Return the name of the package

 Q "RADIOLOGY/NUCLEAR MEDICINE"

PROID() ; Delete the Processing ID field

 Q "@"

ACKTO() ; Return the ACK timeout for CLIENT(SENDER)s

 Q 300

TSTMP() ; Timestamp the protocol entry point with current date/time (in $H format)

 Q $$FMTH^XLFDT($$NOW^XLFDT())

DELITEM ; Delete Item multiple from RA event driver protocols

 N RAA,RAB,RARR,RAX,RAX1,RAY,RAZ

 F RAX="RA REG","RA EXAMINED","RA CANCEL","RA RPT" D

 .S RARR(RAX)=$$FIND1^DIC(101,,"X",RAX)

 .S RARR(RAX_" 2.3")=+$$FIND1^DIC(101,,"X",RAX_" 2.3")

.Q

 F RAX="RA TALKLINK TCP SERVER RPT","RA PSCRIBE TCP SERVER RPT","RA VOICE TCP SERVER RPT" D

 .S RARR(RAX)=+$$FIND1^DIC(101,,"X",RAX)

.Q

 ; remove RA subscriber type items

 S RAX="" F  S RAX=$O(RARR(RAX)) Q:RAX=""  D

 .S RAX1=+$G(RARR(RAX)) Q:'RAX1  ; must be a protocol ien

 .S:'$D(^ORD(101,RAX1,10,0)) ^ORD(101,RAX1,10,0)="^101.01PA^^0"

 .S RAY=0 F  S RAY=$O(^ORD(101,RAX1,10,RAY)) Q:'RAY  D

 ..S RAZ=+$G(^ORD(101,RAX1,10,RAY,0)) ; get the item ien

 ..S RAA=$$GET1^DIQ(101,RAZ,.01,"I") ; protocol name

 ..S RAB=$$GET1^DIQ(101,RAZ,4,"I") ; protocol type

 ..Q:$E(RAA,1,2)'="RA"!(RAB'="S")  ; must be a RA subscriber item type

 ..S RA101(101.01,RAY_","_RAX1_",",.01)="@" D FILE^DIE("K","RA101")

..Q

.Q

RA12PST2  ;HIRMFO/CRT - Post-init functions (patch seventeen) ;5/20/99

VERSION   ;;5.0;Radiology/Nuclear Medicine;**17**;Mar 16, 1998

 +1       ;

MSG(ENTRY,FILE,ERR) ; display a status message pertaining to the addition

 +1       ; of entries to files: 870 & 101.  Display a status message

 +2       ; when items are added to the Protocol (101) file.

 +3       ; Variable list:

 +4       ; ENTRY-> value of the .01 field for a particular file (60 chars max)

 +5       ; FILE -> file # where the data will be added

 +6       ; ERR  -> err message? 1 if yes, else null

 +7        NEW RACNT,RATXT,STRING,WORDS

           SET RACNT=1

           SET RATXT(RACNT)=" "

 +8        IF $GET(ERR)

               SET STRING="* ERROR * "

 +9        SET STRING=$GET(STRING)_"Adding/Editing '"_$EXTRACT(ENTRY,1,40)_"' in the "

 +10       SET STRING=$GET(STRING)_$EXTRACT($PIECE($GET(^DIC(FILE,0)),"^"),1,40)_" file."

 +11      ; display the 1st error text encountered! (there may be more errors. Because of possible string length error display only the first error.)

           IF $GET(ERR)&($DATA(DIERR))

               SET STRING=$GET(STRING)_" "_$EXTRACT($GET(^TMP("DIERR",$JOB,1,"TEXT",1)),1,115)

 +12       IF $GET(ERR)

               SET STRING=$GET(STRING)_" IRM should investigate."

 +13       FOR

               Begin DoDot:1

 +14               SET WORDS=$LENGTH($EXTRACT(STRING,1,71)," ")

 +15               SET RACNT=RACNT+1

                   SET RATXT(RACNT)=$PIECE(STRING," ",1,WORDS)

 +16               SET STRING=$PIECE(STRING," ",WORDS+1,999)

 +17               QUIT

               End DoDot:1

               IF STRING=""

                   QUIT

 +18       DO MES^XPDUTL(.RATXT)

 +19       QUIT

CLIENT()  ; return 'CLIENT (SENDER)', for CLIENT/SERVER (400.03) field

 +1       ; in file 870

 +2        QUIT "CLIENT (SENDER)"

N()       ; return 'NO', for various fields in file 101

 +1        QUIT "NO"

SLISTN()  ; return 'SINGLE LISTENER', for CLIENT/SERVER (400.03) field

 +1       ; in file 870

 +2        QUIT "SINGLE LISTENER"

TCP()     ; return 'TCP' for LLP TYPE (2) field in file 870

 +1        QUIT "TCP"

Y()       ; return 'YES', for PERSISTENT (400.04) field in file 870

 +1        QUIT "YES"

PKG()     ; Return the name of the package

 +1        QUIT "RADIOLOGY/NUCLEAR MEDICINE"

PROID()   ; Delete the Processing ID field

 +1        QUIT "@"

ACKTO()   ; Return the ACK timeout for CLIENT(SENDER)s

 +1        QUIT 300

TSTMP()   ; Timestamp the protocol entry point with current date/time (in $H format)

 +1        QUIT $$FMTH^XLFDT($$NOW^XLFDT())

 +2       ;

DELITEM   ; Delete Item multiple from RA event driver protocols

 +1        NEW RAA,RAB,RARR,RAX,RAX1,RAY,RAZ

 +2        FOR RAX="RA REG","RA EXAMINED","RA CANCEL","RA RPT"

               Begin DoDot:1

 +3                SET RARR(RAX)=$$FIND1^DIC(101,,"X",RAX)

 +4                SET RARR(RAX_" 2.3")=+$$FIND1^DIC(101,,"X",RAX_" 2.3")

 +5                QUIT

               End DoDot:1

 +6        FOR RAX="RA TALKLINK TCP SERVER RPT","RA PSCRIBE TCP SERVER RPT","RA VOICE TCP SERVER RPT"

               Begin DoDot:1

 +7                SET RARR(RAX)=+$$FIND1^DIC(101,,"X",RAX)

 +8                QUIT

               End DoDot:1

 +9       ; remove RA subscriber type items

 +10       SET RAX=""

FOR

               SET RAX=$ORDER(RARR(RAX))

               IF RAX=""

                   QUIT

               Begin DoDot:1

 +11      ; must be a protocol ien

                   SET RAX1=+$GET(RARR(RAX))

                   IF 'RAX1

                       QUIT

 +12               IF '$DATA(^ORD(101,RAX1,10,0))

                       SET ^ORD(101,RAX1,10,0)="^101.01PA^^0"

 +13               SET RAY=0

FOR

                       SET RAY=$ORDER(^ORD(101,RAX1,10,RAY))

                       IF 'RAY

                           QUIT

                       Begin DoDot:2

 +14      ; get the item ien

                           SET RAZ=+$GET(^ORD(101,RAX1,10,RAY,0))

 +15      ; protocol name

                           SET RAA=$$GET1^DIQ(101,RAZ,.01,"I")

 +16      ; protocol type

                           SET RAB=$$GET1^DIQ(101,RAZ,4,"I")

 +17      ; must be a RA subscriber item type

                           IF $EXTRACT(RAA,1,2)'="RA"!(RAB'="S")

                               QUIT

 +18                       SET RA101(101.01,RAY_","_RAX1_",",.01)="@"

                           DO FILE^DIE("K","RA101")

 +19                       QUIT

                       End DoDot:2

 +20               QUIT

               End DoDot:1

 +21       QUIT

RA12PST2.m