- PRCHCS9 ;WISC/RWS,RHD-BUILD ISMS CODE SHEET DATA ;12/1/93 09:53
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ADDRS ;GET BILL TO & SHIP TO ADDRESS
- S PRCH("ST")=$P(^PRC(442,PRCHPO,1),U,3),PRCH("BI")=$P(^(12),U,6)
- S PRCH("CU")=$G(^PRC(411,PRC("SITE"),3))
- I PRCH("ST") S PRCH("ST")=$G(^PRC(411,PRC("SITE"),1,PRCH("ST"),0))
- I PRCH("BI") S PRCH("BI")=$G(^PRC(411,PRC("SITE"),4,PRCH("ST"),0))
- Q
- PRIORITY S X=$S($P($G(^PRC(442,PRCHPO,1)),U,19)=1:3,$P($G(^(17)),U,9)=8:2,1:1),X=$S(PRCHN("SFC")=1:"TO",1:"SO")_X Q
- SETUP ;SETUP VARIABLES - CALLED FROM INPUT TEMPLATE
- Q:'$D(PRCHPO)&0 D ADDRS S PRCHI="",PRCHI("PODATE")=$P(^PRC(442,PRCHPO,1),U,15),PRCH0=^(0) Q
- ITEM ;SET UP LINE ITEM VARIABLES
- Q:PRCFASYS'="ISM"&0 S PRCHI=$O(^PRC(442,PRCHPO,2,PRCHI)),X=$S(PRCHI:PRCHI,1:"") Q:'PRCHI S PRCHI0=^(PRCHI,0) W "." Q
- Q
- BLDAR ; BUILD THE PRCHTP ARRAY
- K PRCHTP D ADDRS S PRCHTP(1)="442,"_PRCHPO_",^PRC(442,",PRCHTP(2)="442.01,PRCHLI,^PRC(442,"_PRCHPO_",2,"
- S PRCHTP(1,1)="S X=""ISM"";500"
- S PRCHTP(1,2)="S X=PRC(""SITE"");1"
- S PRCHTP(1,3)="107;63"
- S PRCHTP(1,4)="D PRIORITY^PRCHCS9;3"
- S PRCHTP(1,5)="S X=""T"";501"
- S PRCHTP(1,6)="S X=""N"";502"
- S PRCHTP(1,6)="S X=PRCHPONO;503"
- S PRCHTP(1,8)="S X=1;504"
- S PRCHTP(1,9)="S X=""|HE"";540"
- S PRCHTP(1,10)=".1;541"
- S PRCHTP(1,11)="S X=""01"";542"
- S PRCHTP(1,12)="7;543"
- S PRCHTP(1,13)="S X=PRCHLCNT;520"
- S PRCHTP(1,14)="S X=""|AC"";570"
- S PRCHTP(1,15)="1.4;78"
- S PRCHTP(1,16)="S X=PRC(""FY"");80"
- S PRCHTP(1,17)="2;81"
- S PRCHTP(1,18)="1;82"
- S PRCHTP(1,19)="S X=""|CU"";512"
- S PRCHTP(1,20)="S X=$P(^PRC(411,PRC(""SITE""),0),U,10);512.2"
- S PRCHTP(1,21)="S X=0;512.1"
- S PRCHTP(1,22)="S X=$P(PRCH(""CU""),U,1);512.3"
- S PRCHTP(1,23)="S X=$P(PRCH(""CU""),U,2);512.4"
- S PRCHTP(1,24)="S X=$P(PRCH(""CU""),U,3);512.7"
- S PRCHTP(1,25)="S X=$P(PRCH(""CU""),U,4) S:X]"""" X=$P($G(^DIC(5,X,0)),U,2);512.8"
- S PRCHTP(1,26)="S X=$P(PRCH(""CU""),U,5);512.9"
- S PRCHTP(1,27)="S X=""|BI"";513"
- S PRCHTP(1,28)="S X=$P(PRCH(""BI""),U,1);513.1"
- S PRCHTP(1,29)="S X=0;513.2"
- S PRCHTP(1,30)="S X=$P(PRCH(""BI""),U,2);513.3"
- S PRCHTP(1,32)="S X=$P(PRCH(""BI""),U,3);513.4"
- S PRCHTP(1,32)="S X=$P(PRCH(""BI""),U,4);513.5"
- S PRCHTP(1,33)="S X=$P(PRCH(""BI""),U,5);513.7"
- S PRCHTP(1,34)="S X=$P(PRCH(""BI""),U,6) S:X]"""" X=$P($G(^DIC(5,X,0)),U,2);513.8"
- S PRCHTP(1,35)="S X=$P(PRCH(""BI""),U,7);513.9"
- S PRCHTP(1,36)="S X=""|ST"";514"
- S PRCHTP(1,37)="S X=$P(PRCH(""ST""),U,1);514.2"
- S PRCHTP(1,38)="S X=0;514.1"
- S PRCHTP(1,39)="S X=$P(PRCH(""ST""),U,2);514.3"
- S PRCHTP(1,40)="S X=$P(PRCH(""ST""),U,3);514.4"
- S PRCHTP(1,41)="S X=$P(PRCH(""ST""),U,4);514.5"
- S PRCHTP(1,42)="S X=$P(PRCH(""ST""),U,5);514.7"
- S PRCHTP(1,43)="S X=$P(PRCH(""ST""),U,6) S:X]"""" X=$P($G(^DIC(5,X,0)),U,2);514.8"
- S PRCHTP(1,44)="S X=$P(PRCH(""ST""),U,7);514.9"
- S PRCHTP(1,45)="D LINE^PRCHCS9 S X=""|$"";507"
- QUIT
- LINE ; TRANSFER LINE ITEM DATA OVER
- N I,J S PRCHI=0 F S PRCHI=$O(^PRC(442,PRCHPO,2,PRCHI)) Q:'PRCHI S X=^(PRCHI,0) W "."_PRCHI D
- .S PRCHI(0,20)="|IT"
- .S PRCHI(0,1)=$P(X,U,1)
- .S PRCHI(0,2)=$P(X,U,13)
- .S PRCHI(0,4)=$P(X,U,4)
- .S PRCHI(1,2)=$P(X,U,3)
- .S PRCHI(0,3)=$P(X,U,16)
- .S PRCHI(1,5)=$P(X,U,4)
- .S PRCHI(1,10)="0"
- .I $D(^PRC(442,PRCHPO,2,PRCHI,4)) N X4 S X4=^(4) D
- ..S PRCHI(1,6)=$P(X4,U,15)
- ..S PRCHI(1,7)=$P(X4,U,16)
- .S $P(^PRCF(423,PRCFA("CSDA"),52,0),U,3,4)=$P(^PRC(442,PRCHPO,2,0),U,3,4)
- .S I="" F S I=$O(PRCHI(I)) Q:I="" S J="" F S J=$O(PRCHI(I,J)) Q:J="" D
- ..S $P(^PRCF(423,PRCFA("CSDA"),52,PRCHI,I),U,J)=PRCHI(I,J)
- S PRCHLI="QUIT" QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCS9 3639 printed Mar 13, 2025@21:11:13 Page 2
- PRCHCS9 ;WISC/RWS,RHD-BUILD ISMS CODE SHEET DATA ;12/1/93 09:53
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- ADDRS ;GET BILL TO & SHIP TO ADDRESS
- +1 SET PRCH("ST")=$PIECE(^PRC(442,PRCHPO,1),U,3)
- SET PRCH("BI")=$PIECE(^(12),U,6)
- +2 SET PRCH("CU")=$GET(^PRC(411,PRC("SITE"),3))
- +3 IF PRCH("ST")
- SET PRCH("ST")=$GET(^PRC(411,PRC("SITE"),1,PRCH("ST"),0))
- +4 IF PRCH("BI")
- SET PRCH("BI")=$GET(^PRC(411,PRC("SITE"),4,PRCH("ST"),0))
- +5 QUIT
- PRIORITY SET X=$SELECT($PIECE($GET(^PRC(442,PRCHPO,1)),U,19)=1:3,$PIECE($GET(^(17)),U,9)=8:2,1:1)
- SET X=$SELECT(PRCHN("SFC")=1:"TO",1:"SO")_X
- QUIT
- SETUP ;SETUP VARIABLES - CALLED FROM INPUT TEMPLATE
- +1 if '$DATA(PRCHPO)&0
- QUIT
- DO ADDRS
- SET PRCHI=""
- SET PRCHI("PODATE")=$PIECE(^PRC(442,PRCHPO,1),U,15)
- SET PRCH0=^(0)
- QUIT
- ITEM ;SET UP LINE ITEM VARIABLES
- +1 if PRCFASYS'="ISM"&0
- QUIT
- SET PRCHI=$ORDER(^PRC(442,PRCHPO,2,PRCHI))
- SET X=$SELECT(PRCHI:PRCHI,1:"")
- if 'PRCHI
- QUIT
- SET PRCHI0=^(PRCHI,0)
- WRITE "."
- QUIT
- +2 QUIT
- BLDAR ; BUILD THE PRCHTP ARRAY
- +1 KILL PRCHTP
- DO ADDRS
- SET PRCHTP(1)="442,"_PRCHPO_",^PRC(442,"
- SET PRCHTP(2)="442.01,PRCHLI,^PRC(442,"_PRCHPO_",2,"
- +2 SET PRCHTP(1,1)="S X=""ISM"";500"
- +3 SET PRCHTP(1,2)="S X=PRC(""SITE"");1"
- +4 SET PRCHTP(1,3)="107;63"
- +5 SET PRCHTP(1,4)="D PRIORITY^PRCHCS9;3"
- +6 SET PRCHTP(1,5)="S X=""T"";501"
- +7 SET PRCHTP(1,6)="S X=""N"";502"
- +8 SET PRCHTP(1,6)="S X=PRCHPONO;503"
- +9 SET PRCHTP(1,8)="S X=1;504"
- +10 SET PRCHTP(1,9)="S X=""|HE"";540"
- +11 SET PRCHTP(1,10)=".1;541"
- +12 SET PRCHTP(1,11)="S X=""01"";542"
- +13 SET PRCHTP(1,12)="7;543"
- +14 SET PRCHTP(1,13)="S X=PRCHLCNT;520"
- +15 SET PRCHTP(1,14)="S X=""|AC"";570"
- +16 SET PRCHTP(1,15)="1.4;78"
- +17 SET PRCHTP(1,16)="S X=PRC(""FY"");80"
- +18 SET PRCHTP(1,17)="2;81"
- +19 SET PRCHTP(1,18)="1;82"
- +20 SET PRCHTP(1,19)="S X=""|CU"";512"
- +21 SET PRCHTP(1,20)="S X=$P(^PRC(411,PRC(""SITE""),0),U,10);512.2"
- +22 SET PRCHTP(1,21)="S X=0;512.1"
- +23 SET PRCHTP(1,22)="S X=$P(PRCH(""CU""),U,1);512.3"
- +24 SET PRCHTP(1,23)="S X=$P(PRCH(""CU""),U,2);512.4"
- +25 SET PRCHTP(1,24)="S X=$P(PRCH(""CU""),U,3);512.7"
- +26 SET PRCHTP(1,25)="S X=$P(PRCH(""CU""),U,4) S:X]"""" X=$P($G(^DIC(5,X,0)),U,2);512.8"
- +27 SET PRCHTP(1,26)="S X=$P(PRCH(""CU""),U,5);512.9"
- +28 SET PRCHTP(1,27)="S X=""|BI"";513"
- +29 SET PRCHTP(1,28)="S X=$P(PRCH(""BI""),U,1);513.1"
- +30 SET PRCHTP(1,29)="S X=0;513.2"
- +31 SET PRCHTP(1,30)="S X=$P(PRCH(""BI""),U,2);513.3"
- +32 SET PRCHTP(1,32)="S X=$P(PRCH(""BI""),U,3);513.4"
- +33 SET PRCHTP(1,32)="S X=$P(PRCH(""BI""),U,4);513.5"
- +34 SET PRCHTP(1,33)="S X=$P(PRCH(""BI""),U,5);513.7"
- +35 SET PRCHTP(1,34)="S X=$P(PRCH(""BI""),U,6) S:X]"""" X=$P($G(^DIC(5,X,0)),U,2);513.8"
- +36 SET PRCHTP(1,35)="S X=$P(PRCH(""BI""),U,7);513.9"
- +37 SET PRCHTP(1,36)="S X=""|ST"";514"
- +38 SET PRCHTP(1,37)="S X=$P(PRCH(""ST""),U,1);514.2"
- +39 SET PRCHTP(1,38)="S X=0;514.1"
- +40 SET PRCHTP(1,39)="S X=$P(PRCH(""ST""),U,2);514.3"
- +41 SET PRCHTP(1,40)="S X=$P(PRCH(""ST""),U,3);514.4"
- +42 SET PRCHTP(1,41)="S X=$P(PRCH(""ST""),U,4);514.5"
- +43 SET PRCHTP(1,42)="S X=$P(PRCH(""ST""),U,5);514.7"
- +44 SET PRCHTP(1,43)="S X=$P(PRCH(""ST""),U,6) S:X]"""" X=$P($G(^DIC(5,X,0)),U,2);514.8"
- +45 SET PRCHTP(1,44)="S X=$P(PRCH(""ST""),U,7);514.9"
- +46 SET PRCHTP(1,45)="D LINE^PRCHCS9 S X=""|$"";507"
- +47 QUIT
- LINE ; TRANSFER LINE ITEM DATA OVER
- +1 NEW I,J
- SET PRCHI=0
- FOR
- SET PRCHI=$ORDER(^PRC(442,PRCHPO,2,PRCHI))
- if 'PRCHI
- QUIT
- SET X=^(PRCHI,0)
- WRITE "."_PRCHI
- Begin DoDot:1
- +2 SET PRCHI(0,20)="|IT"
- +3 SET PRCHI(0,1)=$PIECE(X,U,1)
- +4 SET PRCHI(0,2)=$PIECE(X,U,13)
- +5 SET PRCHI(0,4)=$PIECE(X,U,4)
- +6 SET PRCHI(1,2)=$PIECE(X,U,3)
- +7 SET PRCHI(0,3)=$PIECE(X,U,16)
- +8 SET PRCHI(1,5)=$PIECE(X,U,4)
- +9 SET PRCHI(1,10)="0"
- +10 IF $DATA(^PRC(442,PRCHPO,2,PRCHI,4))
- NEW X4
- SET X4=^(4)
- Begin DoDot:2
- +11 SET PRCHI(1,6)=$PIECE(X4,U,15)
- +12 SET PRCHI(1,7)=$PIECE(X4,U,16)
- End DoDot:2
- +13 SET $PIECE(^PRCF(423,PRCFA("CSDA"),52,0),U,3,4)=$PIECE(^PRC(442,PRCHPO,2,0),U,3,4)
- +14 SET I=""
- FOR
- SET I=$ORDER(PRCHI(I))
- if I=""
- QUIT
- SET J=""
- FOR
- SET J=$ORDER(PRCHI(I,J))
- if J=""
- QUIT
- Begin DoDot:2
- +15 SET $PIECE(^PRCF(423,PRCFA("CSDA"),52,PRCHI,I),U,J)=PRCHI(I,J)
- End DoDot:2
- End DoDot:1
- +16 SET PRCHLI="QUIT"
- QUIT
