PRCHMOP.m

PRCHMOP ;ISC2/RWS-ORDER NUMBER ACK (ONA) TRANSMITTER ;8-20-92/09:55

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

READ ; READ SYSID AND LINE COUNT SEGMENTS

 S X=$Q(@TRANSIN),SYSEG=@X

 S X=$Q(@X),LCSEG=@X I $P(LCSEG,U,1)'="LC" S ERR="SEGMENT TYPE SHOULD BE LC" Q

 S LCNT=$P(LCSEG,U,2),ISNO=$P(SYSEG,U,7),IFNO=$P(LCSEG,U,3),IFNO=$E(IFNO,1,3)_"-"_$E(IFNO,4,99)

 F  Q:$A($E(ISNO,$L(ISNO)))'=32  S ISNO=$E(ISNO,1,$L(ISNO)-1)

 S ^XMB(3.9,XMZ,2,1,0)="      IFCAP Requisition Number "_IFNO_" has been assigned # "_ISNO_" in ISMS."

 S ^XMB(3.9,XMZ,2,2,0)=""

 S ^XMB(3.9,XMZ,2,3,0)=""

 S ^XMB(3.9,XMZ,2,4,0)=""

 S ^XMB(3.9,XMZ,2,5,0)=""

 S LIN=5 I $Q(@X)=""!(+LCNT'=0) S ERR="LINE COUNT ERROR" Q

 D ACK

EXIT Q

ACK ;TRANSMIT ISMS PO # TO IFCAP PO

 S DA=$O(^PRC(442,"B",IFNO,0)) I DA="" S ERR="REQUISITION NUMBER NOT FOUND" Q

 S DIE="^PRC(442,",DR="110///^S X=ISNO",DR(2,442.17)="1///" D ^DIE

 K DA,DIE,DR Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCHMOP   966     printed  Apr 09, 2024@21:12:58                                                                                                                                                                                                      Page 2

PRCHMOP   ;ISC2/RWS-ORDER NUMBER ACK (ONA) TRANSMITTER ;8-20-92/09:55

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

READ      ; READ SYSID AND LINE COUNT SEGMENTS

 +1        SET X=$QUERY(@TRANSIN)

           SET SYSEG=@X

 +2        SET X=$QUERY(@X)

           SET LCSEG=@X

           IF $PIECE(LCSEG,U,1)'="LC"

               SET ERR="SEGMENT TYPE SHOULD BE LC"

               QUIT 

 +3        SET LCNT=$PIECE(LCSEG,U,2)

           SET ISNO=$PIECE(SYSEG,U,7)

           SET IFNO=$PIECE(LCSEG,U,3)

           SET IFNO=$EXTRACT(IFNO,1,3)_"-"_$EXTRACT(IFNO,4,99)

 +4        FOR 

               if $ASCII($EXTRACT(ISNO,$LENGTH(ISNO)))'=32

                   QUIT 

               SET ISNO=$EXTRACT(ISNO,1,$LENGTH(ISNO)-1)

 +5        SET ^XMB(3.9,XMZ,2,1,0)="      IFCAP Requisition Number "_IFNO_" has been assigned # "_ISNO_" in ISMS."

 +6        SET ^XMB(3.9,XMZ,2,2,0)=""

 +7        SET ^XMB(3.9,XMZ,2,3,0)=""

 +8        SET ^XMB(3.9,XMZ,2,4,0)=""

 +9        SET ^XMB(3.9,XMZ,2,5,0)=""

 +10       SET LIN=5

           IF $QUERY(@X)=""!(+LCNT'=0)

               SET ERR="LINE COUNT ERROR"

               QUIT 

 +11       DO ACK

EXIT       QUIT 

ACK       ;TRANSMIT ISMS PO # TO IFCAP PO

 +1        SET DA=$ORDER(^PRC(442,"B",IFNO,0))

           IF DA=""

               SET ERR="REQUISITION NUMBER NOT FOUND"

               QUIT 

 +2        SET DIE="^PRC(442,"

           SET DR="110///^S X=ISNO"

           SET DR(2,442.17)="1///"

           DO ^DIE

 +3        KILL DA,DIE,DR

           QUIT