PRCFFU2 ;WISC/SJG-FMS MO2 SEGMENT ;9/7/10 15:11
;;5.1;IFCAP;**130,148**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
;
MO2(NODE,TYCODE) ;BUILD 'MO2' SEGMENT
; .1 - P.O. DATE FROM 442 .01 - NAME FROM 440
; 5 - VENDOR FROM 442 .06 - FEDERAL SOURCE FROM 440
; 6.4 - FOB POINT FROM 442 34 - FMS VENDOR CODE FROM 440
; 35 - ALT-ADDR-IND FROM 440
MO2A N SEG,FMSYR,FMSMO,FMSDAY,VEND,FMSVENCD,FMSVENNM,FMSPODAT,FMSFOB
S (FMSVENID,FMSVENCD,FMSVENNM,FMSFOB)=""
S TMPLINE=TMPLINE+1
K PRCTMP N DA S DIC=442,DR=".1;5;6.4",DA=+PO,DIQ="PRCTMP(",DIQ(0)="IE" D EN^DIQ1 K DIC,DIQ,DR
MO2B I (TRCODE="MO")&(("^1^3^4^7^8^26^"[("^"_PRCFA("MP")_"^"))) D
.S (BEGDATE,FMSPODAT,PODATE)=PRCFA("OBLDATE")
.D DATE(FMSPODAT,.A,.B,.C) S FMSPODAT=FMSYR_U_FMSMO_U_FMSDAY
MO2C I (TRCODE="SO")&(PRCFA("MP")=2) D
.S (BEGDATE,FMSPODAT,PODATE)=PRCFA("OBLDATE")
.D DATE(FMSPODAT,.A,.B,.C) S FMSPODAT=FMSYR_U_FMSMO_U_FMSDAY
MO2D I (TRCODE="SO")&(PRCFA("MP")=21) D
.I TYCODE="E" D
..S (BEGDATE,FMSPODAT,PODATE)=PRCFA("OBLDATE")
..S FMSPODAT=$E(PODATE,2,3)_U_$E(PODATE,4,5)_U_$E(PODATE,6,7)
..Q
.I TYCODE="M" D
..S (BEGDATE,FMSPODAT,PODATE)=PRCFA("OBLDATE")
..D DATE(FMSPODAT,.A,.B,.C) S FMSPODAT=FMSYR_U_FMSMO_U_FMSDAY
..Q
MO2E D
.I TYCODE="M" Q:'PRCFA("FOB")
.S (FMSFOB,FOB)=$G(PRCTMP(442,+PO,6.4,"I"))
.I FOB="" S (FMSFOB,FOB)="D"
MO2F D
.I TYCODE="M" Q:'PRCFA("VEND")
.S VEND=$G(PRCTMP(442,+PO,5,"I"))
.I VEND]"" D
..N DA S DIC=440,DR=".01;.06;34;35",DA=+VEND,DIQ="PRCTMP(",DIQ(0)="IE" D EN^DIQ1 K DIC,DIQ,DR
..S FMSVENID=$G(PRCTMP(440,VEND,34,"E"))
..S FMSVENCD=$G(PRCTMP(440,VEND,35,"E"))
..S FMSVENNM=$G(PRCTMP(440,VEND,.01,"E"))
..S FMSVENNM=$E(FMSVENNM,1,30)
..I FMSVENID="" D
...S FMSFED=$G(PRCTMP(440,VEND,.06,"I"))
...S FMSVENID=$S(FMSFED:"MISCG",'FMSFED:"MISCN")
.I VEND="" I TRCODE="SO" S FMSVENID="MISCN",(FMSVENCD,FMSVENNM)=""
MO2G S SEG="MO2^"_FMSPODAT
N ACCMO,ACCYR,ACCPD
S ACCPD=$P($G(PRCFA("ACCPD")),U),ACCMO=$E(ACCPD,1,2),ACCYR=$E(ACCPD,3,4)
S $P(SEG,U,5)=ACCMO,$P(SEG,U,6)=ACCYR,$P(SEG,U,10)=TYCODE
I TRCODE="SO" S $P(SEG,U,11)=$S(PRCFA("MP")=2:"C",PRCFA("MP")=21:"T",1:"")
I TRCODE="SO",PRCFA("MP")=21 S $P(SEG,U,13)=$$AUTH(+PO,"SO",PRCFA("MP"))
I FMSVENID]"" S $P(SEG,U,14)=FMSVENID
I FMSVENCD]"" S $P(SEG,U,15)=FMSVENCD
I (FMSVENID="MISCN")!(FMSVENID="MISCG") I FMSVENNM]"" S $P(SEG,U,16)=FMSVENNM
I FMSFOB]"" S $P(SEG,U,24)=FMSFOB
S ^TMP($J,"PRCMO",INT,TMPLINE)=SEG_"^~" K PRCTMP
Q
;
DATE(X,A,B,C) ;
S FMSYR=$E(X,2,3),FMSMO=$E(X,4,5),FMSDAY=$E(X,6,7)
Q
DATE1(X) ;
Q $E(X,4,5)_$E(X,6,7)_$E(X,2,3)
Q
ASKDATE(X) ;
N Y,ASKDATE
S %DT="AEX",%DT("A")=X D ^%DT
S ASKDATE=Y K %DT
Q ASKDATE
;
AUTH(PRCIEN,PRCCODE,PRCMOP) ;Extrinsic function returns authority/sub-authority code for 1358
N PRCDA,PRCX,PRCY S PRCX=""
G AUTHX:$G(PRCIEN)'>0,AUTHX:$G(PRCCODE)'="SO",AUTHX:$G(PRCMOP)'=21
S PRCDA=$P($G(^PRC(442,PRCIEN,0)),U,12) G AUTHX:PRCDA'>0
S PRCY=$P($G(^PRCS(410,PRCDA,11)),U,5) S:PRCY'>0 PRCY=$P($G(^(11)),U,4)
G AUTHX:PRCY'>0
S PRCX=$P($G(^PRCS(410.9,PRCY,0)),U,7)
AUTHX Q PRCX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFU2 3179 printed Oct 16, 2024@18:04:28 Page 2
PRCFFU2 ;WISC/SJG-FMS MO2 SEGMENT ;9/7/10 15:11
+1 ;;5.1;IFCAP;**130,148**;Oct 20, 2000;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
MO2(NODE,TYCODE) ;BUILD 'MO2' SEGMENT
+1 ; .1 - P.O. DATE FROM 442 .01 - NAME FROM 440
+2 ; 5 - VENDOR FROM 442 .06 - FEDERAL SOURCE FROM 440
+3 ; 6.4 - FOB POINT FROM 442 34 - FMS VENDOR CODE FROM 440
+4 ; 35 - ALT-ADDR-IND FROM 440
MO2A NEW SEG,FMSYR,FMSMO,FMSDAY,VEND,FMSVENCD,FMSVENNM,FMSPODAT,FMSFOB
+1 SET (FMSVENID,FMSVENCD,FMSVENNM,FMSFOB)=""
+2 SET TMPLINE=TMPLINE+1
+3 KILL PRCTMP
NEW DA
SET DIC=442
SET DR=".1;5;6.4"
SET DA=+PO
SET DIQ="PRCTMP("
SET DIQ(0)="IE"
DO EN^DIQ1
KILL DIC,DIQ,DR
MO2B IF (TRCODE="MO")&(("^1^3^4^7^8^26^"[("^"_PRCFA("MP")_"^")))
Begin DoDot:1
+1 SET (BEGDATE,FMSPODAT,PODATE)=PRCFA("OBLDATE")
+2 DO DATE(FMSPODAT,.A,.B,.C)
SET FMSPODAT=FMSYR_U_FMSMO_U_FMSDAY
End DoDot:1
MO2C IF (TRCODE="SO")&(PRCFA("MP")=2)
Begin DoDot:1
+1 SET (BEGDATE,FMSPODAT,PODATE)=PRCFA("OBLDATE")
+2 DO DATE(FMSPODAT,.A,.B,.C)
SET FMSPODAT=FMSYR_U_FMSMO_U_FMSDAY
End DoDot:1
MO2D IF (TRCODE="SO")&(PRCFA("MP")=21)
Begin DoDot:1
+1 IF TYCODE="E"
Begin DoDot:2
+2 SET (BEGDATE,FMSPODAT,PODATE)=PRCFA("OBLDATE")
+3 SET FMSPODAT=$EXTRACT(PODATE,2,3)_U_$EXTRACT(PODATE,4,5)_U_$EXTRACT(PODATE,6,7)
+4 QUIT
End DoDot:2
+5 IF TYCODE="M"
Begin DoDot:2
+6 SET (BEGDATE,FMSPODAT,PODATE)=PRCFA("OBLDATE")
+7 DO DATE(FMSPODAT,.A,.B,.C)
SET FMSPODAT=FMSYR_U_FMSMO_U_FMSDAY
+8 QUIT
End DoDot:2
End DoDot:1
MO2E Begin DoDot:1
+1 IF TYCODE="M"
if 'PRCFA("FOB")
QUIT
+2 SET (FMSFOB,FOB)=$GET(PRCTMP(442,+PO,6.4,"I"))
+3 IF FOB=""
SET (FMSFOB,FOB)="D"
End DoDot:1
MO2F Begin DoDot:1
+1 IF TYCODE="M"
if 'PRCFA("VEND")
QUIT
+2 SET VEND=$GET(PRCTMP(442,+PO,5,"I"))
+3 IF VEND]""
Begin DoDot:2
+4 NEW DA
SET DIC=440
SET DR=".01;.06;34;35"
SET DA=+VEND
SET DIQ="PRCTMP("
SET DIQ(0)="IE"
DO EN^DIQ1
KILL DIC,DIQ,DR
+5 SET FMSVENID=$GET(PRCTMP(440,VEND,34,"E"))
+6 SET FMSVENCD=$GET(PRCTMP(440,VEND,35,"E"))
+7 SET FMSVENNM=$GET(PRCTMP(440,VEND,.01,"E"))
+8 SET FMSVENNM=$EXTRACT(FMSVENNM,1,30)
+9 IF FMSVENID=""
Begin DoDot:3
+10 SET FMSFED=$GET(PRCTMP(440,VEND,.06,"I"))
+11 SET FMSVENID=$SELECT(FMSFED:"MISCG",'FMSFED:"MISCN")
End DoDot:3
End DoDot:2
+12 IF VEND=""
IF TRCODE="SO"
SET FMSVENID="MISCN"
SET (FMSVENCD,FMSVENNM)=""
End DoDot:1
MO2G SET SEG="MO2^"_FMSPODAT
+1 NEW ACCMO,ACCYR,ACCPD
+2 SET ACCPD=$PIECE($GET(PRCFA("ACCPD")),U)
SET ACCMO=$EXTRACT(ACCPD,1,2)
SET ACCYR=$EXTRACT(ACCPD,3,4)
+3 SET $PIECE(SEG,U,5)=ACCMO
SET $PIECE(SEG,U,6)=ACCYR
SET $PIECE(SEG,U,10)=TYCODE
+4 IF TRCODE="SO"
SET $PIECE(SEG,U,11)=$SELECT(PRCFA("MP")=2:"C",PRCFA("MP")=21:"T",1:"")
+5 IF TRCODE="SO"
IF PRCFA("MP")=21
SET $PIECE(SEG,U,13)=$$AUTH(+PO,"SO",PRCFA("MP"))
+6 IF FMSVENID]""
SET $PIECE(SEG,U,14)=FMSVENID
+7 IF FMSVENCD]""
SET $PIECE(SEG,U,15)=FMSVENCD
+8 IF (FMSVENID="MISCN")!(FMSVENID="MISCG")
IF FMSVENNM]""
SET $PIECE(SEG,U,16)=FMSVENNM
+9 IF FMSFOB]""
SET $PIECE(SEG,U,24)=FMSFOB
+10 SET ^TMP($JOB,"PRCMO",INT,TMPLINE)=SEG_"^~"
KILL PRCTMP
+11 QUIT
+12 ;
DATE(X,A,B,C) ;
+1 SET FMSYR=$EXTRACT(X,2,3)
SET FMSMO=$EXTRACT(X,4,5)
SET FMSDAY=$EXTRACT(X,6,7)
+2 QUIT
DATE1(X) ;
+1 QUIT $EXTRACT(X,4,5)_$EXTRACT(X,6,7)_$EXTRACT(X,2,3)
+2 QUIT
ASKDATE(X) ;
+1 NEW Y,ASKDATE
+2 SET %DT="AEX"
SET %DT("A")=X
DO ^%DT
+3 SET ASKDATE=Y
KILL %DT
+4 QUIT ASKDATE
+5 ;
AUTH(PRCIEN,PRCCODE,PRCMOP) ;Extrinsic function returns authority/sub-authority code for 1358
+1 NEW PRCDA,PRCX,PRCY
SET PRCX=""
+2 if $GET(PRCIEN)'>0
GOTO AUTHX
if $GET(PRCCODE)'="SO"
GOTO AUTHX
if $GET(PRCMOP)'=21
GOTO AUTHX
+3 SET PRCDA=$PIECE($GET(^PRC(442,PRCIEN,0)),U,12)
if PRCDA'>0
GOTO AUTHX
+4 SET PRCY=$PIECE($GET(^PRCS(410,PRCDA,11)),U,5)
if PRCY'>0
SET PRCY=$PIECE($GET(^(11)),U,4)
+5 if PRCY'>0
GOTO AUTHX
+6 SET PRCX=$PIECE($GET(^PRCS(410.9,PRCY,0)),U,7)
AUTHX QUIT PRCX
