- PRCHAMXH ;WISC/DJM-'CHANGES' ROUTINES FOR 443.6 ;12/2/94 2:52 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;****NOTE-See PRCHAMXA for information on variable PRCHNORE and
- ;incidence of undefined DIK variable errors.
- ;
- EN0 ;SAVES 'CHANGES' INFORMATION FOR 'ITEM' MULTIPLE, 'DESCRIPTION' MULTIPLE.
- D DELCHK
- N FF,PRCHDA1,RECORD,Y
- S FF="1;443.61:40",PRCHDA1=PRCHPO,RECORD=+PRCHI
- D SAVE(FF,PRCHDA1,RECORD)
- Q
- ;
- SAVE(FF,PRCHDA1,RECORD) ;THIS WILL DO THE ACTUAL SAVING OF THE INFORMATION.
- ;'PRCHAM' IS DEFINED FROM AMENDMENT ROUTINES.
- ;IT IS THE 'AMENDMENT' FIELD'S RECORD NUMBER FOR THE AMENDMENT THAT
- ;IS BEING ENTERED.
- ;'PRCHAMDA' IS THE INTERNAL # OF THE AMENDMENT TYPE BEING USED, FROM
- ;FILE 442.2 (P.O.) OR 441.6 (REQUISITION).
- N PRCHDA,OLD,DIFLD,DIP,F2NUMBER,ALREADY,DS,D,D0,D1,D2,DIG,DIH,DISYS,DIU,DIV,J,L,DH,DU,DV,DW,DOV,LINE1,DIOV
- S F2NUMBER=0,ALREADY=$O(^PRC(443.6,"C",PRCHDA1,PRCHAM,FF,RECORD,F2NUMBER,0))
- Q:ALREADY>0 ;CHECK IF THIS FIELD HAS ALREADY BEEN ENTERED. ONLY THE FIRST ENTRY IS NEEDED.
- S PRCHDA="",LINE1=$O(^PRC(442,PRCHDA1,2,RECORD,1,0)) Q:LINE1'>0
- S OLD=$G(^PRC(442,PRCHDA1,2,RECORD,1,LINE1,0)) Q:OLD=""
- N DA,X
- D NEXT(PRCHDA1,PRCHAM,.PRCHDA)
- N DIE,DC,DD,DE,DG,DIEL,DI,DK,DL,DM,DO,DP,DQ,DR
- S DA(2)=PRCHDA1,DA(1)=PRCHAM,DA=PRCHDA,DIE="^PRC(443.6,"_DA(2)_",6,"_DA(1)_",3,"
- S DR="1////^S X=PRCHAMDA;2////^S X=FF;3///^S X=OLD;4///^S X=RECORD;7////^S X=F2NUMBER" D ^DIE
- S DA(3)=DA(2),DA(2)=DA(1),DA(1)=DA,DIE="^PRC(443.6,"_DA(3)_",6,"_DA(2)_",3,"_DA(1)_",1,",ZERO=$G(^PRC(443.6,DA(3),6,DA(2),3,DA(1),1,0))
- F S LINE1=$O(^PRC(442,PRCHDA1,2,RECORD,1,LINE1)) Q:LINE1'>0 D
- .S OLD=$G(^PRC(442,PRCHDA1,2,RECORD,1,LINE1,0)) Q:OLD=""
- .S DA=LINE1,^PRC(443.6,DA(3),6,DA(2),3,DA(1),1,DA,0)=OLD,$P(ZERO,U,3)=DA,$P(ZERO,U,4)=$P(ZERO,U,4)+1
- .Q
- S ^PRC(443.6,DA(3),6,DA(2),3,DA(1),1,0)=ZERO
- Q
- ;
- NEXT(DA,DA1,DA2) ;COME HERE TO CREATE THE NEXT ENTRY IN THE 'CHANGES' MULTIPLE.
- ;DA2 IS RETURNED WITH THE 'CHANGES' INTERNAL RECORD NUMBER.
- N AA,BB,DIC,DD,DINUM,DO,X,Y
- S AA=$G(^PRC(443.6,DA,6,DA1,3,0)) I AA="" S AA=1,^PRC(443.6,DA,6,DA1,3,0)="^"_$P(^DD(443.67,14,0),"^",2) G ENTER
- S AA=$P(AA,U,3)
- FIND S AA=AA+1,BB=$G(^PRC(443.6,DA,6,DA1,3,AA,0)) I BB'="" G FIND
- ENTER K DD,DO S DA(2)=DA,DA(1)=DA1,DIC="^PRC(443.6,"_DA(2)_",6,"_DA(1)_",3,",DIC(0)="L",(DINUM,X)=AA D FILE^DICN G:+Y'>0 FIND
- S DA2=+Y Q
- DELCHK ; Checks to see if any delivery schedule has a delivery schedule
- ; quantity that is not >0. If so and there is an entry in 442.8
- ; a delete flag is entered in 441.7 and the quantity is set to 0.
- ; If there is no entry in 442.8 the 441.7 entry is deleted.
- N NUM,J,K,DA
- S NUM=$P(^PRC(442,PRCHPO,0),U)
- I $D(^PRC(441.7,"AG",NUM)) D
- . S J=0 F S J=$O(^PRC(441.7,"AG",NUM,J)) Q:J'>0 D
- . . S K=0 F S K=$O(^PRC(441.7,"AG",NUM,J,K)) Q:K'>0 D
- . . . I $P(^PRC(441.7,K,0),U,5)'>0,($P(^PRC(441.7,K,0),U,7)']"") D Q
- . . . . S DIK="^PRC(441.7,",DA=K D ^DIK K DIK
- . . . I $P(^PRC(441.7,K,0),U,5)'>0,($P(^PRC(441.7,K,0),U,7)]"") D Q
- . . . . S $P(^PRC(441.7,K,0),U,6)="D"
- . . . . S $P(^PRC(441.7,K,0),U,5)=0
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAMXH 3169 printed Dec 13, 2024@02:05:53 Page 2
- PRCHAMXH ;WISC/DJM-'CHANGES' ROUTINES FOR 443.6 ;12/2/94 2:52 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- +3 ;****NOTE-See PRCHAMXA for information on variable PRCHNORE and
- +4 ;incidence of undefined DIK variable errors.
- +5 ;
- EN0 ;SAVES 'CHANGES' INFORMATION FOR 'ITEM' MULTIPLE, 'DESCRIPTION' MULTIPLE.
- +1 DO DELCHK
- +2 NEW FF,PRCHDA1,RECORD,Y
- +3 SET FF="1;443.61:40"
- SET PRCHDA1=PRCHPO
- SET RECORD=+PRCHI
- +4 DO SAVE(FF,PRCHDA1,RECORD)
- +5 QUIT
- +6 ;
- SAVE(FF,PRCHDA1,RECORD) ;THIS WILL DO THE ACTUAL SAVING OF THE INFORMATION.
- +1 ;'PRCHAM' IS DEFINED FROM AMENDMENT ROUTINES.
- +2 ;IT IS THE 'AMENDMENT' FIELD'S RECORD NUMBER FOR THE AMENDMENT THAT
- +3 ;IS BEING ENTERED.
- +4 ;'PRCHAMDA' IS THE INTERNAL # OF THE AMENDMENT TYPE BEING USED, FROM
- +5 ;FILE 442.2 (P.O.) OR 441.6 (REQUISITION).
- +6 NEW PRCHDA,OLD,DIFLD,DIP,F2NUMBER,ALREADY,DS,D,D0,D1,D2,DIG,DIH,DISYS,DIU,DIV,J,L,DH,DU,DV,DW,DOV,LINE1,DIOV
- +7 SET F2NUMBER=0
- SET ALREADY=$ORDER(^PRC(443.6,"C",PRCHDA1,PRCHAM,FF,RECORD,F2NUMBER,0))
- +8 ;CHECK IF THIS FIELD HAS ALREADY BEEN ENTERED. ONLY THE FIRST ENTRY IS NEEDED.
- if ALREADY>0
- QUIT
- +9 SET PRCHDA=""
- SET LINE1=$ORDER(^PRC(442,PRCHDA1,2,RECORD,1,0))
- if LINE1'>0
- QUIT
- +10 SET OLD=$GET(^PRC(442,PRCHDA1,2,RECORD,1,LINE1,0))
- if OLD=""
- QUIT
- +11 NEW DA,X
- +12 DO NEXT(PRCHDA1,PRCHAM,.PRCHDA)
- +13 NEW DIE,DC,DD,DE,DG,DIEL,DI,DK,DL,DM,DO,DP,DQ,DR
- +14 SET DA(2)=PRCHDA1
- SET DA(1)=PRCHAM
- SET DA=PRCHDA
- SET DIE="^PRC(443.6,"_DA(2)_",6,"_DA(1)_",3,"
- +15 SET DR="1////^S X=PRCHAMDA;2////^S X=FF;3///^S X=OLD;4///^S X=RECORD;7////^S X=F2NUMBER"
- DO ^DIE
- +16 SET DA(3)=DA(2)
- SET DA(2)=DA(1)
- SET DA(1)=DA
- SET DIE="^PRC(443.6,"_DA(3)_",6,"_DA(2)_",3,"_DA(1)_",1,"
- SET ZERO=$GET(^PRC(443.6,DA(3),6,DA(2),3,DA(1),1,0))
- +17 FOR
- SET LINE1=$ORDER(^PRC(442,PRCHDA1,2,RECORD,1,LINE1))
- if LINE1'>0
- QUIT
- Begin DoDot:1
- +18 SET OLD=$GET(^PRC(442,PRCHDA1,2,RECORD,1,LINE1,0))
- if OLD=""
- QUIT
- +19 SET DA=LINE1
- SET ^PRC(443.6,DA(3),6,DA(2),3,DA(1),1,DA,0)=OLD
- SET $PIECE(ZERO,U,3)=DA
- SET $PIECE(ZERO,U,4)=$PIECE(ZERO,U,4)+1
- +20 QUIT
- End DoDot:1
- +21 SET ^PRC(443.6,DA(3),6,DA(2),3,DA(1),1,0)=ZERO
- +22 QUIT
- +23 ;
- NEXT(DA,DA1,DA2) ;COME HERE TO CREATE THE NEXT ENTRY IN THE 'CHANGES' MULTIPLE.
- +1 ;DA2 IS RETURNED WITH THE 'CHANGES' INTERNAL RECORD NUMBER.
- +2 NEW AA,BB,DIC,DD,DINUM,DO,X,Y
- +3 SET AA=$GET(^PRC(443.6,DA,6,DA1,3,0))
- IF AA=""
- SET AA=1
- SET ^PRC(443.6,DA,6,DA1,3,0)="^"_$PIECE(^DD(443.67,14,0),"^",2)
- GOTO ENTER
- +4 SET AA=$PIECE(AA,U,3)
- FIND SET AA=AA+1
- SET BB=$GET(^PRC(443.6,DA,6,DA1,3,AA,0))
- IF BB'=""
- GOTO FIND
- ENTER KILL DD,DO
- SET DA(2)=DA
- SET DA(1)=DA1
- SET DIC="^PRC(443.6,"_DA(2)_",6,"_DA(1)_",3,"
- SET DIC(0)="L"
- SET (DINUM,X)=AA
- DO FILE^DICN
- if +Y'>0
- GOTO FIND
- +1 SET DA2=+Y
- QUIT
- DELCHK ; Checks to see if any delivery schedule has a delivery schedule
- +1 ; quantity that is not >0. If so and there is an entry in 442.8
- +2 ; a delete flag is entered in 441.7 and the quantity is set to 0.
- +3 ; If there is no entry in 442.8 the 441.7 entry is deleted.
- +4 NEW NUM,J,K,DA
- +5 SET NUM=$PIECE(^PRC(442,PRCHPO,0),U)
- +6 IF $DATA(^PRC(441.7,"AG",NUM))
- Begin DoDot:1
- +7 SET J=0
- FOR
- SET J=$ORDER(^PRC(441.7,"AG",NUM,J))
- if J'>0
- QUIT
- Begin DoDot:2
- +8 SET K=0
- FOR
- SET K=$ORDER(^PRC(441.7,"AG",NUM,J,K))
- if K'>0
- QUIT
- Begin DoDot:3
- +9 IF $PIECE(^PRC(441.7,K,0),U,5)'>0
- IF ($PIECE(^PRC(441.7,K,0),U,7)']"")
- Begin DoDot:4
- +10 SET DIK="^PRC(441.7,"
- SET DA=K
- DO ^DIK
- KILL DIK
- End DoDot:4
- QUIT
- +11 IF $PIECE(^PRC(441.7,K,0),U,5)'>0
- IF ($PIECE(^PRC(441.7,K,0),U,7)]"")
- Begin DoDot:4
- +12 SET $PIECE(^PRC(441.7,K,0),U,6)="D"
- +13 SET $PIECE(^PRC(441.7,K,0),U,5)=0
- End DoDot:4
- QUIT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +14 QUIT